refacto
This commit is contained in:
parent
68dd8ec479
commit
bd60cea184
5 changed files with 158 additions and 107 deletions
|
@ -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
|
||||
|
|
103
src/Aggreact.hs
103
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
|
||||
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)
|
||||
|
||||
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 =
|
||||
|
|
98
src/Aggreact/Auth.hs
Normal file
98
src/Aggreact/Auth.hs
Normal file
|
@ -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"
|
|
@ -1,5 +1,5 @@
|
|||
{-# LANGUAGE DataKinds #-}
|
||||
-- Local Pragmas
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE Strict #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
|
||||
|
|
|
@ -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")
|
||||
|
|
Loading…
Reference in a new issue