From bd60cea18476f0aabf516e5e5af5eb4d8492cc8e Mon Sep 17 00:00:00 2001 From: "Yann Esposito (Yogsototh)" Date: Tue, 22 Jan 2019 23:57:30 +0100 Subject: [PATCH] refacto --- aggreact.cabal | 3 +- src/Aggreact.hs | 113 +++++--------------------------- src/Aggreact/Auth.hs | 98 +++++++++++++++++++++++++++ src/Aggreact/Comments/Server.hs | 2 +- src/Aggreact/Homepage.hs | 49 +++++++++++--- 5 files changed, 158 insertions(+), 107 deletions(-) create mode 100644 src/Aggreact/Auth.hs diff --git a/aggreact.cabal b/aggreact.cabal index 97ddb44..58e9abb 100644 --- a/aggreact.cabal +++ b/aggreact.cabal @@ -2,7 +2,7 @@ -- -- see: https://github.com/sol/hpack -- --- hash: baf75307a9c628aa3d68c8e108beda42a689496d986f883d8d19ca9e1da2961a +-- hash: ec76b06d212428d6ff4f3f2daa7d453c6af2a54687257bb60e02c5f738d12e1d name: aggreact version: 0.1.0.0 @@ -28,6 +28,7 @@ source-repository head library exposed-modules: Aggreact + Aggreact.Auth Aggreact.Comments Aggreact.Comments.Server Aggreact.Comments.StoreService diff --git a/src/Aggreact.hs b/src/Aggreact.hs index 5097431..4386817 100644 --- a/src/Aggreact.hs +++ b/src/Aggreact.hs @@ -7,7 +7,6 @@ -- Common {-# LANGUAGE BlockArguments #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE ExplicitForAll #-} {-# LANGUAGE NamedWildCards #-} @@ -42,70 +41,38 @@ module Aggreact import Protolude +import Aggreact.Auth import Aggreact.Comments -import Aggreact.Html -import Aggreact.Css (genCss) import Aggreact.Homepage import Aggreact.User -import Clay (Css) -import Data.Aeson -import Data.Time (getCurrentTime) import Network.Wai (Application) import Servant -import Servant.Errors -import Servant.Clay -import Servant.HTML.Blaze -import qualified Web.FormUrlEncoded as Form - --- Auth -import Network.Wai.Handler.Warp (run) import Servant.Auth.Server +import Network.Wai.Handler.Warp (run) -data Conf = Conf { port :: Int - , jwtKeyFilePath :: FilePath - , cookieSettings :: CookieSettings - , userDBConf :: UserDBConf - , commentDBConf :: CommentDBConf - } deriving (Eq, Show) - --- defaultCookieSettings { cookieIsSecure = NotSecure --- , cookieXsrfSetting = Nothing --- , cookieSameSite = AnySite } --- Auth - -data Login = Login - { username :: Text - , password :: Text - } deriving (Eq, Show, Read, Generic) - -instance ToJSON Login -instance FromJSON Login -instance Form.FromForm Login where - fromForm = Form.genericFromForm Form.FormOptions {fieldLabelModifier = identity} - -type Unauthenticated = - "login" - :> (ReqBody '[JSON, FormUrlEncoded] Login - :> PostNoContent '[JSON, FormUrlEncoded] - (Headers '[ Header "Set-Cookie" SetCookie - , Header "Set-Cookie" SetCookie] - NoContent) - :<|> Get '[HTML] LoginPage) +data Conf = + Conf + { port :: Int + , jwtKeyFilePath :: FilePath + , cookieSettings :: CookieSettings + , userDBConf :: UserDBConf + , commentDBConf :: CommentDBConf + } deriving (Eq, Show) type API auths = Auth auths User :> Authenticated - :<|> Unauthenticated + :<|> LoginAPI type Authenticated = HomepageAPI :<|> CommentAPI serverAuthenticated :: Settings - -> Servant.Auth.Server.AuthResult User - -> Server (Authenticated) -serverAuthenticated settings@Settings{..} authresult = - homepageAPI settings authresult + -> AuthResult User + -> Server Authenticated +serverAuthenticated Settings{..} authresult = + homepageAPI commentHandler authresult :<|> commentAPI (Aggreact.Comments.Handlers userHandler commentHandler) authresult data Settings = @@ -116,61 +83,15 @@ data Settings = } server :: Settings -> Server (API auths) -server settings = +server settings@Settings{..} = serverAuthenticated settings - :<|> checkCreds settings - :<|> return LoginPage + :<|> serverLoginAPI (LoginSettings cookieSettings jwtSettings userHandler) mainServe :: Conf -> IO () mainServe conf = do (Settings{..},app) <- initialize conf run (port conf) app --- Here is the login handler -checkCreds :: Settings - -> Login - -> Handler (Headers '[ Header "Set-Cookie" SetCookie - , Header "Set-Cookie" SetCookie] - NoContent) -checkCreds Settings{..} (Login loginNick loginPass) = do - muser <- liftIO $ checkUserLogin userHandler loginNick loginPass - case muser of - Just user -> do - putText "Found some User!" - print user - mApplyCookies <- liftIO $ acceptLogin cookieSettings jwtSettings user - case mApplyCookies of - Nothing -> unauthorized "Could not create a cookie" - Just applyCookies -> return $ applyCookies NoContent - _ -> do - putErrText "User not found" - unauthorized "User not found" - --- / Auth - -type HomepageAPI = - "main.css" :> Get '[CSS] Css - :<|> Get '[HTML] Homepage - -homepageAPI :: Settings - -> Servant.Auth.Server.AuthResult User - -> Server HomepageAPI -homepageAPI settings@Settings{..} authResult = - let muser = case authResult of - (Servant.Auth.Server.Authenticated user) -> Just user - _ -> Nothing - in - return genCss - :<|> initHomepage muser settings - -initHomepage :: Maybe User -> Settings -> Handler Homepage -initHomepage muser Settings{..} = - liftIO $ Homepage <$> getLatestSlugs commentHandler - <*> getTopSlugs commentHandler - <*> getLatestComments commentHandler - <*> getCurrentTime - <*> return muser - -- -- * User API -- -- type UserAPI = diff --git a/src/Aggreact/Auth.hs b/src/Aggreact/Auth.hs new file mode 100644 index 0000000..6fdee74 --- /dev/null +++ b/src/Aggreact/Auth.hs @@ -0,0 +1,98 @@ +-- Local Pragmas +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE Strict #-} +{-# LANGUAGE TypeOperators #-} + +-- Common Pragmas (already stated in cabal file but repeated here for some tools) +{-# LANGUAGE BlockArguments #-} -- blabla do ... instead of blabla $ do ... +{-# LANGUAGE DerivingStrategies #-} -- remove warn about deriving strategies +{-# LANGUAGE ExplicitForAll #-} -- f :: forall a b. a -> b -> b +{-# LANGUAGE NamedWildCards #-} -- can use _type instead of just _ +{-# LANGUAGE NoImplicitPrelude #-} -- to use protolude for example +{-# LANGUAGE NumericUnderscores #-} -- write 1_000 instead of 1000 +{-# LANGUAGE OverloadedLists #-} -- write [1,2,3] :: Set +{-# LANGUAGE OverloadedStrings #-} -- write "foo" and it will be the correct text type +{-# LANGUAGE PartialTypeSignatures #-} -- write foo :: (_) => a -> Bool +{-# LANGUAGE RecordWildCards #-} -- f Conf{..} = field1 ... +{-# LANGUAGE ScopedTypeVariables #-} -- write expr :: Type inside an expression +{- | +Module : Aggreact.Comments.StoreService +Description : CommentStore service +Copyright : (c) 2018, Yann Esposito +License : ISC +Maintainer : yann.esposito@gmail.com +Stability : experimental +Portability : POSIX + +Comment Routes and Servant Handlers + +-} + +module Aggreact.Auth +where + +-------------------------------------------------------------------------------- +import Protolude + +-------------------------------------------------------------------------------- +import Aggreact.Html +import Aggreact.User (UserHandler(..), checkUserLogin) + +-------------------------------------------------------------------------------- +import Data.Aeson +import Servant +import Servant.Errors +import Servant.HTML.Blaze (HTML) +import Servant.Auth.Server +import qualified Web.FormUrlEncoded as Form + +data Login = Login + { username :: Text + , password :: Text + } deriving (Eq, Show, Read, Generic) + +instance ToJSON Login +instance FromJSON Login +instance Form.FromForm Login where + fromForm = Form.genericFromForm Form.FormOptions {fieldLabelModifier = identity} + +type LoginAPI = + "login" + :> (ReqBody '[JSON, FormUrlEncoded] Login + :> PostNoContent '[JSON, FormUrlEncoded] + (Headers '[ Header "Set-Cookie" SetCookie + , Header "Set-Cookie" SetCookie] + NoContent) + :<|> Get '[HTML] LoginPage) + +serverLoginAPI :: LoginSettings -> Server LoginAPI +serverLoginAPI loginSettings = + checkCreds loginSettings + :<|> return LoginPage + +data LoginSettings = + LoginSettings + { cookieSettings :: CookieSettings + , jwtSettings :: JWTSettings + , userHandler :: UserHandler + } + +-- Here is the login handler +checkCreds :: LoginSettings + -> Login + -> Handler (Headers '[ Header "Set-Cookie" SetCookie + , Header "Set-Cookie" SetCookie] + NoContent) +checkCreds LoginSettings{..} (Login loginNick loginPass) = do + muser <- liftIO $ checkUserLogin userHandler loginNick loginPass + case muser of + Just user -> do + putText "Found some User!" + print user + mApplyCookies <- liftIO $ acceptLogin cookieSettings jwtSettings user + case mApplyCookies of + Nothing -> unauthorized "Could not create a cookie" + Just applyCookies -> return $ applyCookies NoContent + _ -> do + putErrText "User not found" + unauthorized "User not found" diff --git a/src/Aggreact/Comments/Server.hs b/src/Aggreact/Comments/Server.hs index e6c6692..38415c3 100644 --- a/src/Aggreact/Comments/Server.hs +++ b/src/Aggreact/Comments/Server.hs @@ -1,5 +1,5 @@ -{-# LANGUAGE DataKinds #-} -- Local Pragmas +{-# LANGUAGE DataKinds #-} {-# LANGUAGE Strict #-} {-# LANGUAGE TypeOperators #-} diff --git a/src/Aggreact/Homepage.hs b/src/Aggreact/Homepage.hs index 55ce792..0731c0f 100644 --- a/src/Aggreact/Homepage.hs +++ b/src/Aggreact/Homepage.hs @@ -1,14 +1,14 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE BlockArguments #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE ExplicitForAll #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE NamedWildCards #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE NumericUnderscores #-} @@ -17,9 +17,7 @@ {-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE Strict #-} -{-# LANGUAGE TupleSections #-} {- | Module : Aggreact.Comments Description : Example of a library file. @@ -35,17 +33,25 @@ Main datastructures module Aggreact.Homepage ( Homepage(..) + , HomepageAPI + , homepageAPI ) where import Protolude -import Aggreact.Comments (Comment, Slug (..), - displayOneComment) +import Aggreact.Comments (Comment, CommentHandler(..), + Slug (..), displayOneComment) +import Aggreact.Css (genCss) import Aggreact.Html (boilerplate, loginWidget, urlEncode) import Aggreact.User (User) +import Clay (Css) import Data.String (IsString (..)) -import Data.Time (UTCTime) +import Data.Time (UTCTime, getCurrentTime) +import Servant +import Servant.Auth.Server +import Servant.Clay +import Servant.HTML.Blaze import qualified Text.Blaze.Html5 as H import qualified Text.Blaze.Html5.Attributes as A @@ -56,6 +62,31 @@ data Homepage = Homepage { latestSlugs :: [(Slug,Int)] , muser :: Maybe User } + +type HomepageAPI = + "main.css" :> Get '[CSS] Css + :<|> Get '[HTML] Homepage + +homepageAPI :: CommentHandler + -> Servant.Auth.Server.AuthResult User + -> Server HomepageAPI +homepageAPI commentHandler authResult = + let muser = case authResult of + (Authenticated user) -> Just user + _ -> Nothing + in + return genCss + :<|> getHomepage muser commentHandler + +getHomepage :: Maybe User -> CommentHandler -> Handler Homepage +getHomepage muser commentHandler = + liftIO $ Homepage <$> getLatestSlugs commentHandler + <*> getTopSlugs commentHandler + <*> getLatestComments commentHandler + <*> getCurrentTime + <*> return muser + + instance H.ToMarkup Homepage where toMarkup Homepage {..} = boilerplate (loginWidget muser) $ do H.p "Bienvenue sur Aggreact!" @@ -64,8 +95,8 @@ instance H.ToMarkup Homepage where H.h2 "Top" H.ul $ traverse_ htmlSlug topSlugs H.h2 "Latest comments" - H.ul $ traverse_ (flip displayOneComment viewTime) latestComments - where htmlSlug ((Slug s),n) = + H.ul $ traverse_ (`displayOneComment` viewTime) latestComments + where htmlSlug (Slug s,n) = H.li $ do H.a H.! A.href (fromString (toS ("/comments/" <> urlEncode (toS s)))) $ H.text s H.div H.! A.class_ "metas" $ H.text (show n <> " comments")