yogsototh/aggreact
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

refacto

Browse source
This commit is contained in:
Yann Esposito (Yogsototh) 2019-01-22 23:57:30 +01:00
parent 68dd8ec479
commit bd60cea184
Signed by untrusted user who does not match committer: yogsototh
GPG key ID: 7B19A4C650D59646
5 changed files with 158 additions and 107 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

3
aggreact.cabal
View file

@ -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

113
src/Aggreact.hs
View file

@ -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 =

98
src/Aggreact/Auth.hs Normal file
View 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"

2
src/Aggreact/Comments/Server.hs
View file

@ -1,5 +1,5 @@
{-# LANGUAGE DataKinds #-}
-- Local Pragmas
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE Strict #-}
{-# LANGUAGE TypeOperators #-}

49
src/Aggreact/Homepage.hs
View file

@ -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")