diff --git a/src-exe/Main.hs b/src-exe/Main.hs index 7e4f6b2..4b2aad9 100644 --- a/src-exe/Main.hs +++ b/src-exe/Main.hs @@ -12,6 +12,7 @@ main = do { cookieIsSecure = NotSecure , cookieXsrfSetting = Nothing , cookieSameSite = AnySite } + , slugDBConf = SQLiteConf "aggreact.db" "slugs" , userDBConf = SQLiteConf "aggreact.db" "users" , commentDBConf = SQLiteConf "aggreact.db" "comments" , authorizationStrategy = Anybody diff --git a/src/Aggreact.hs b/src/Aggreact.hs index 4688200..f935557 100644 --- a/src/Aggreact.hs +++ b/src/Aggreact.hs @@ -46,6 +46,7 @@ import Aggreact.Auth import Aggreact.Authorization import Aggreact.Comments import Aggreact.Homepage +import Aggreact.Slugs import Aggreact.User import Network.Wai (Application) @@ -59,6 +60,7 @@ data Conf = , jwtKeyFilePath :: FilePath , cookieSettings :: CookieSettings , userDBConf :: UserDBConf + , slugDBConf :: SlugDBConf , commentDBConf :: CommentDBConf , authorizationStrategy :: AuthorizationStrategy } deriving (Eq, Show) @@ -70,6 +72,7 @@ type API auths = type Authenticated = HomepageAPI :<|> CommentAPI + :<|> SlugAPI :<|> UserAPI serverAuthenticated :: Settings @@ -78,11 +81,13 @@ serverAuthenticated :: Settings serverAuthenticated Settings{..} authresult = homepageAPI commentHandler authresult :<|> commentAPI (Aggreact.Comments.Handlers userHandler commentHandler authorizationHandler) authresult + :<|> slugAPI (Aggreact.Slugs.Handlers userHandler slugHandler authorizationHandler) authresult :<|> userAPI userHandler authresult data Settings = Settings { cookieSettings :: CookieSettings , jwtSettings :: JWTSettings + , slugHandler :: SlugHandler , userHandler :: UserHandler , commentHandler :: CommentHandler , authorizationHandler :: AuthorizationHandler @@ -104,6 +109,7 @@ initialize :: Conf -> IO (Settings,Application) initialize Conf{..} = do uh <- newUserHandler userDBConf defaultAdminUser ch <- newCommentHandler (dbstore uh) commentDBConf + sh <- newSlugHandler (dbstore uh) slugDBConf ah <- newAuthorizationHandler authorizationStrategy myKey <- readKey jwtKeyFilePath let jwtSettings = defaultJWTSettings myKey @@ -112,6 +118,7 @@ initialize Conf{..} = do let settings = Settings { jwtSettings = jwtSettings , cookieSettings = cookieSettings + , slugHandler = sh , userHandler = uh , commentHandler = ch , authorizationHandler = ah diff --git a/src/Aggreact/Authorization.hs b/src/Aggreact/Authorization.hs index 7946230..75675ab 100644 --- a/src/Aggreact/Authorization.hs +++ b/src/Aggreact/Authorization.hs @@ -79,14 +79,14 @@ strToScope txt = unloggedScopes :: AuthorizationStrategy -> Scopes unloggedScopes Anybody = [ "comment" - , "stub"] + , "slug:read"] & traverse strToScope & fmap Set.fromList & fromMaybe Set.empty unloggedScopes LoggedInOnly = [ "comment:read" - , "stub:read"] + , "slug:read"] & traverse strToScope & fmap Set.fromList & fromMaybe Set.empty @@ -94,7 +94,7 @@ unloggedScopes LoggedInOnly = scopesFor :: NewUser -> AuthorizationStrategy -> Set Scope scopesFor _ Anybody = [ "comment" - , "homepage"] + , "slug:read"] & traverse strToScope & fmap Set.fromList & fromMaybe Set.empty @@ -102,9 +102,9 @@ scopesFor _ Anybody = scopesFor u LoggedInOnly = let scs = case role u of User -> [ "comment" - , "stub:read"] + , "slug:read"] Admin -> [ "comment" - , "stub"] + , "slug"] in scs & traverse strToScope diff --git a/src/Aggreact/Slugs/Server.hs b/src/Aggreact/Slugs/Server.hs index f8f36f2..1f48bf4 100644 --- a/src/Aggreact/Slugs/Server.hs +++ b/src/Aggreact/Slugs/Server.hs @@ -35,25 +35,28 @@ where import Protolude -------------------------------------------------------------------------------- -import Aggreact.Authorization (Access (..), - AuthorizationHandler (..)) -import Aggreact.Scopes (Scope (..)) -import Aggreact.Slugs.StoreService (SlugHandler (..)) +import Aggreact.Authorization (Access (..), + AuthorizationHandler (..)) +import Aggreact.Scopes (Scope (..)) +import Aggreact.Slugs.StoreService (SlugHandler (..)) import Aggreact.Slugs.Types import Aggreact.Slugs.Views -import Aggreact.User (User, UserHandler (..)) +import Aggreact.User (User, UserHandler (..), + UserId (..)) -------------------------------------------------------------------------------- -import qualified Data.IxSet.Typed as IxSet -import Data.Time (getCurrentTime) -import qualified Data.UUID as UUID -import Database.Store (Entity (..), Id (..), minimalId) +import Data.Time (getCurrentTime) +import Database.SQLite.Simple (NamedParam ((:=))) +import Database.Store (Entity (..), minimalId) +import Database.Store.Backend.SQLite (SearchQuery (Filter), + SearchResult (SR)) +import qualified Database.Store.Backend.SQLite as SQL import Servant -import Servant.Auth.Server (AuthResult (..)) +import Servant.Auth.Server (AuthResult (..)) import Servant.Errors -import Servant.HTML.Blaze (HTML) +import Servant.HTML.Blaze (HTML) -type SlutAPI = +type SlugAPI = "slugs" :> Get '[JSON] [Slug] :<|> "slugs" :> Capture "slug" Text @@ -78,39 +81,49 @@ slugAPI Handlers{..} authResult = :<|> showSlug muser authorizationHandler slugHandler :<|> postNewSlug muser authorizationHandler slugHandler -showSlug :: Maybe User -> AuthorizationHandler -> CommentHandler -> Text -> Handler SlugsPage -showSlug muser AuthorizationHandler{..} CommentHandler{..} s = do - _ <- filterAccess (Scope "slug" Read) muser - cvs <- liftIO $ commentsView (Slug s) - now <- liftIO getCurrentTime - liftIO $ print cvs - return SlugsPage { url = s - , viewTime = now - , muser = muser - , canComment = hasScope (Scope "comment" Read) muser - } - showSlugs :: Maybe User -> AuthorizationHandler - -> CommentHandler + -> SlugHandler -> Handler [Slug] -showSlugs muser AuthorizationHandler{..} ch = do +showSlugs muser AuthorizationHandler{..} sh = do _ <- filterAccess (Scope "comment" Read) muser - liftIO (getSlugs ch) + liftIO (getSlugs sh) + +showSlug :: Maybe User + -> AuthorizationHandler + -> SlugHandler + -> Text + -> Handler SlugPage +showSlug muser AuthorizationHandler{..} SlugHandler{..} slUrl = do + _ <- filterAccess (Scope "slug" Read) muser + (SR (SQL.Paginated slugs _ _)) <- liftIO $ searchSlugs (Filter {params = ["slugUrl" := slUrl]}) + case slugs of + [] -> notFound "Cannot find the slug you're looking for" + (s:[]) -> do + now <- liftIO getCurrentTime + return SlugPage + { spSlug = s + , viewTime = now + , muser = muser + , canCreateSlug = hasScope (Scope "slug" Write) muser + } + _ -> internalServerError "Something went wrong, duplicate slugs..." muserToUserId :: Maybe User -> UserId muserToUserId Nothing = UserId (toS minimalId) muserToUserId (Just (Entity i _ _)) = UserId (toS i) - postNewSlug :: Maybe User -> AuthorizationHandler - -> CommentHandler - -> NewComment - -> Handler CreatedComment -postNewSlug muser AuthorizationHandler{..} ch nc = do - _ <- filterAccess (Scope "comment" Write) muser - let uid = muserToUserId muser - CreatedComment <$> liftIO getCurrentTime - <*> liftIO (createComment ch (nc { userid = uid })) - <*> return muser + -> SlugHandler + -> NewSlug + -> Handler CreatedSlug +postNewSlug muser AuthorizationHandler{..} SlugHandler{..} ns = do + _ <- filterAccess (Scope "slug" Write) muser + (SR (SQL.Paginated slugs _ _)) <- liftIO $ searchSlugs (Filter {params = ["slugUrl" := (slugUrl ns)]}) + if null slugs + then CreatedSlug + <$> liftIO getCurrentTime + <*> liftIO (createSlug (ns { userid = muserToUserId muser })) + <*> return muser + else forbidden "This slug already exists." diff --git a/src/Aggreact/Slugs/Views.hs b/src/Aggreact/Slugs/Views.hs index 398f748..52f6967 100644 --- a/src/Aggreact/Slugs/Views.hs +++ b/src/Aggreact/Slugs/Views.hs @@ -48,14 +48,11 @@ import Aggreact.User (NewUser (..), User, loginWidget) -------------------------------------------------------------------------------- import Data.Aeson (ToJSON (..)) -import Data.Duration (approximativeDuration) -import qualified Data.IxSet.Typed as IxSet import Data.String (IsString (..)) -import Data.Time (UTCTime, diffUTCTime) +import Data.Time (UTCTime) import Data.Time.Clock.Serialize () import Data.Time.Format () -import qualified Data.UUID as UUID -import Database.Store (DefaultMetas (..), Entity (..)) +import Database.Store (Entity (..)) import Text.Blaze.Html5 ((!)) import qualified Text.Blaze.Html5 as H import qualified Text.Blaze.Html5.Attributes as A @@ -63,20 +60,20 @@ import qualified Text.Blaze.Html5.Attributes as A -- * Single Slug Page --- | data SlugPage = SlugPage - { slug :: Slug -- ^ the comment id for the url - , slugPageViewTime :: UTCTime -- ^ the time of watching the comment - , muser :: Maybe User -- ^ Viewer - , canCreateSlug :: Bool -- ^ true if the user is authorized to comment + { spSlug :: Slug + , viewTime :: UTCTime + , muser :: Maybe User + , canCreateSlug :: Bool } + instance ToJSON SlugPage where - toJSON sp = toJSON (slug sp) + toJSON sp = toJSON (spSlug sp) instance H.ToMarkup SlugPage where toMarkup SlugPage{..} = boilerplate (loginWidget muser) $ do - let sl = slug & val & slugUrl & toS + let sl = spSlug & val & slugUrl & toS H.h2 $ do H.a ! A.href ("/comments/" <> cvt (urlEncode (toS sl))) $ H.text "Slug" H.text " for " @@ -112,7 +109,6 @@ instance ToJSON CreatedSlug where slugLink :: Slug -> H.Html slugLink sl = do let s = slugUrl (val sl) - i = id sl url = toS ("/comments/" <> urlEncode (toS s)) H.a ! A.href (fromString url) $ H.text (toS s) @@ -124,24 +120,3 @@ instance H.ToMarkup CreatedSlug where H.text "Slugs for " slugLink createdSlug -- displayOneSlug slug viewTime - -data SlugsPage = - SlugsPage - { spSlug :: Slug - , viewTime :: UTCTime - , muser :: Maybe User - , canCreateSlug :: Bool - } - -instance ToJSON SlugsPage where - toJSON cp = toJSON (spSlug cp) - -instance H.ToMarkup SlugsPage where - toMarkup SlugsPage{..} = do - boilerplate (loginWidget muser) $ do - let url = slugUrl . val $ spSlug - H.h2 $ do - H.text "Slugs for " - H.a ! A.href (cvt url) $ H.text (toS url) - slugForm canCreateSlug url (fmap (toS . nick . val) muser) - diff --git a/src/DevelMain.hs b/src/DevelMain.hs index e065024..bb53386 100644 --- a/src/DevelMain.hs +++ b/src/DevelMain.hs @@ -71,6 +71,7 @@ update = do { cookieIsSecure = NotSecure , cookieXsrfSetting = Nothing , cookieSameSite = AnySite } + , slugDBConf = SQLiteConf "aggreact.db" "slugs" , userDBConf = SQLiteConf "aggreact.db" "users" , commentDBConf = SQLiteConf "aggreact.db" "comments" , authorizationStrategy = Anybody