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

🚧 WIP 🚧

Browse source
This commit is contained in:
Yann Esposito (Yogsototh) 2019-04-13 12:11:48 +02:00
parent a213ce9ba5
commit fb40bb3f30
Signed by untrusted user who does not match committer: yogsototh
GPG key ID: 7B19A4C650D59646
8 changed files with 458 additions and 27 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

125
src/.stack-work/intero/intero34QmaL-STAGING.hs Normal file
View file

@ -0,0 +1,125 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE Strict #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeSynonymInstances #-}
-- Common
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE NamedWildCards #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{- |
Module : Aggreact
Description : Example of a library file.
Copyright : (c) 2018, Yann Esposito
License : ISC
Maintainer : yann.esposito@gmail.com
Stability : experimental
Portability : POSIX
Main library
-}
module Aggreact
(
-- * Exported functions
mainServe
, Conf (..)
, AuthorizationStrategy (..)
, initialize
, shutdownApp
) where
import Protolude
import Aggreact.Auth
import Aggreact.Authorization
import Aggreact.Comments
import Aggreact.Homepage
import Aggreact.User
import Network.Wai (Application)
import Network.Wai.Handler.Warp (run)
import Servant
import Servant.Auth.Server
data Conf =
Conf
{ port :: Int
, jwtKeyFilePath :: FilePath
, cookieSettings :: CookieSettings
, userDBConf :: UserDBConf
, commentDBConf :: CommentDBConf
, authorizationStrategy :: AuthorizationStrategy
} deriving (Eq, Show)
type API auths =
Auth auths User :> Authenticated
:<|> LoginAPI
type Authenticated =
HomepageAPI
:<|> CommentAPI
:<|> UserAPI
serverAuthenticated :: Settings
-> AuthResult User
-> Server Authenticated
serverAuthenticated Settings{..} authresult =
homepageAPI commentHandler authresult
:<|> commentAPI (Aggreact.Comments.Handlers userHandler commentHandler authorizationHandler) authresult
:<|> userAPI userHandler authresult
data Settings =
Settings { cookieSettings :: CookieSettings
, jwtSettings :: JWTSettings
, userHandler :: UserHandler
, commentHandler :: CommentHandler
, authorizationHandler :: AuthorizationHandler
}
server :: Settings -> Server (API auths)
server settings@Settings{..} =
serverAuthenticated settings
:<|> serverLoginAPI (LoginSettings cookieSettings jwtSettings userHandler)
mainServe :: Conf -> IO ()
mainServe conf = do
(Settings{..},app) <- initialize conf
run (port conf) app
-- * Init & Stop app
initialize :: Conf -> IO (Settings,Application)
initialize Conf{..} = do
uh <- newUserHandler userDBConf defaultAdminUser
ch <- newCommentHandler (dbstore uh) commentDBConf
ah <- newAuthorizationHandler authorizationStrategy
myKey <- readKey jwtKeyFilePath
let jwtSettings = defaultJWTSettings myKey
cfg = cookieSettings :. jwtSettings :. EmptyContext
api = Proxy :: Proxy (API '[Cookie,JWT])
let settings =
Settings { jwtSettings = jwtSettings
, cookieSettings = cookieSettings
, userHandler = uh
, commentHandler = ch
, authorizationHandler = ah
}
return ( settings
, serveWithContext api cfg (server settings))
shutdownApp :: Settings -> IO ()
shutdownApp Settings{..} = do
stopDBComments commentHandler
stopDBUsers userHandler

0
src/.stack-work/intero/intero7l3oJR-TEMP.hs Normal file
View file

125
src/.stack-work/intero/interoiVdWfA-TEMP.hs Normal file
View file

@ -0,0 +1,125 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE Strict #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeSynonymInstances #-}
-- Common
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE NamedWildCards #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{- |
Module : Aggreact
Description : Example of a library file.
Copyright : (c) 2018, Yann Esposito
License : ISC
Maintainer : yann.esposito@gmail.com
Stability : experimental
Portability : POSIX
Main library
-}
module Aggreact
(
-- * Exported functions
mainServe
, Conf (..)
, AuthorizationStrategy (..)
, initialize
, shutdownApp
) where
import Protolude
import Aggreact.Auth
import Aggreact.Authorization
import Aggreact.Comments
import Aggreact.Homepage
import Aggreact.User
import Network.Wai (Application)
import Network.Wai.Handler.Warp (run)
import Servant
import Servant.Auth.Server
data Conf =
Conf
{ port :: Int
, jwtKeyFilePath :: FilePath
, cookieSettings :: CookieSettings
, userDBConf :: UserDBConf
, commentDBConf :: CommentDBConf
, authorizationStrategy :: AuthorizationStrategy
} deriving (Eq, Show)
type API auths =
Auth auths User :> Authenticated
:<|> LoginAPI
type Authenticated =
HomepageAPI
:<|> CommentAPI
:<|> UserAPI
serverAuthenticated :: Settings
-> AuthResult User
-> Server Authenticated
serverAuthenticated Settings{..} authresult =
homepageAPI commentHandler authresult
:<|> commentAPI (Aggreact.Comments.Handlers userHandler commentHandler authorizationHandler) authresult
:<|> userAPI userHandler authresult
data Settings =
Settings { cookieSettings :: CookieSettings
, jwtSettings :: JWTSettings
, userHandler :: UserHandler
, commentHandler :: CommentHandler
, authorizationHandler :: AuthorizationHandler
}
server :: Settings -> Server (API auths)
server settings@Settings{..} =
serverAuthenticated settings
:<|> serverLoginAPI (LoginSettings cookieSettings jwtSettings userHandler)
mainServe :: Conf -> IO ()
mainServe conf = do
(Settings{..},app) <- initialize conf
run (port conf) app
-- * Init & Stop app
initialize :: Conf -> IO (Settings,Application)
initialize Conf{..} = do
uh <- newUserHandler userDBConf defaultAdminUser
ch <- newCommentHandler (dbstore uh) commentDBConf
ah <- newAuthorizationHandler authorizationStrategy
myKey <- readKey jwtKeyFilePath
let jwtSettings = defaultJWTSettings myKey
cfg = cookieSettings :. jwtSettings :. EmptyContext
api = Proxy :: Proxy (API '[Cookie,JWT])
let settings =
Settings { jwtSettings = jwtSettings
, cookieSettings = cookieSettings
, userHandler = uh
, commentHandler = ch
, authorizationHandler = ah
}
return ( settings
, serveWithContext api cfg (server settings))
shutdownApp :: Settings -> IO ()
shutdownApp Settings{..} = do
stopDBComments commentHandler
stopDBUsers userHandler

125
src/.stack-work/intero/interoqO1nqM-STAGING.hs Normal file
View file

@ -0,0 +1,125 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE Strict #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeSynonymInstances #-}
-- Common
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE NamedWildCards #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{- |
Module : Aggreact
Description : Example of a library file.
Copyright : (c) 2018, Yann Esposito
License : ISC
Maintainer : yann.esposito@gmail.com
Stability : experimental
Portability : POSIX
Main library
-}
module Aggreact
(
-- * Exported functions
mainServe
, Conf (..)
, AuthorizationStrategy (..)
, initialize
, shutdownApp
) where
import Protolude
import Aggreact.Auth
import Aggreact.Authorization
import Aggreact.Comments
import Aggreact.Homepage
import Aggreact.User
import Network.Wai (Application)
import Network.Wai.Handler.Warp (run)
import Servant
import Servant.Auth.Server
data Conf =
Conf
{ port :: Int
, jwtKeyFilePath :: FilePath
, cookieSettings :: CookieSettings
, userDBConf :: UserDBConf
, commentDBConf :: CommentDBConf
, authorizationStrategy :: AuthorizationStrategy
} deriving (Eq, Show)
type API auths =
Auth auths User :> Authenticated
:<|> LoginAPI
type Authenticated =
HomepageAPI
:<|> CommentAPI
:<|> UserAPI
serverAuthenticated :: Settings
-> AuthResult User
-> Server Authenticated
serverAuthenticated Settings{..} authresult =
homepageAPI commentHandler authresult
:<|> commentAPI (Aggreact.Comments.Handlers userHandler commentHandler authorizationHandler) authresult
:<|> userAPI userHandler authresult
data Settings =
Settings { cookieSettings :: CookieSettings
, jwtSettings :: JWTSettings
, userHandler :: UserHandler
, commentHandler :: CommentHandler
, authorizationHandler :: AuthorizationHandler
}
server :: Settings -> Server (API auths)
server settings@Settings{..} =
serverAuthenticated settings
:<|> serverLoginAPI (LoginSettings cookieSettings jwtSettings userHandler)
mainServe :: Conf -> IO ()
mainServe conf = do
(Settings{..},app) <- initialize conf
run (port conf) app
-- * Init & Stop app
initialize :: Conf -> IO (Settings,Application)
initialize Conf{..} = do
uh <- newUserHandler userDBConf defaultAdminUser
ch <- newCommentHandler (dbstore uh) commentDBConf
ah <- newAuthorizationHandler authorizationStrategy
myKey <- readKey jwtKeyFilePath
let jwtSettings = defaultJWTSettings myKey
cfg = cookieSettings :. jwtSettings :. EmptyContext
api = Proxy :: Proxy (API '[Cookie,JWT])
let settings =
Settings { jwtSettings = jwtSettings
, cookieSettings = cookieSettings
, userHandler = uh
, commentHandler = ch
, authorizationHandler = ah
}
return ( settings
, serveWithContext api cfg (server settings))
shutdownApp :: Settings -> IO ()
shutdownApp Settings{..} = do
stopDBComments commentHandler
stopDBUsers userHandler

28
src/Aggreact/Authorization.hs
View file

@ -26,7 +26,6 @@ Depending on the user provide different trust mechanism
module Aggreact.Authorization
( AuthorizationStrategy (..)
, AuthorizationHandler (..)
, Scope(..)
, Access(..)
, newAuthorizationHandler
)
@ -34,13 +33,14 @@ where
import Protolude
import Aggreact.User (NewUser (..), Role (..), User)
import Aggreact.Scopes (Access (..), Scope (..), Scopes)
import Aggreact.User (NewUser (..), Role (..), User)
import qualified Data.Set as Set
import qualified Data.Text as Text
import Database.Store (Entity (..))
import Servant (Handler)
import Servant.Errors (unauthorized)
import qualified Data.Set as Set
import qualified Data.Text as Text
import Database.Store (Entity (..))
import Servant (Handler)
import Servant.Errors (unauthorized)
data AuthorizationStrategy =
Anybody
@ -53,14 +53,6 @@ data AuthorizationHandler =
, hasScope :: Scope -> Maybe User -> Bool
}
data Scope = Scope { resource :: Text
, access :: Access }
deriving (Eq, Ord, Show)
data Access = Read | Write
deriving (Eq, Ord, Show)
type Scopes = Set Scope
newAuthorizationHandler :: AuthorizationStrategy -> IO AuthorizationHandler
newAuthorizationHandler as = pure
AuthorizationHandler
@ -76,10 +68,10 @@ strToScope txt =
accessTxt = Text.dropWhile (/= sep) txt
sep = ':'
accessValue = case accessTxt of
":read" -> Just Read
":read" -> Just Read
":write" -> Just Write
"" -> Just Write
_ -> Nothing
"" -> Just Write
_ -> Nothing
unloggedScopes :: AuthorizationStrategy -> Scopes
unloggedScopes Anybody =

16
src/Aggreact/Comments/Views.hs
View file

@ -1,4 +1,4 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
@ -70,6 +70,7 @@ data CommentPage =
, commentPageViewTime :: UTCTime -- ^ the time of watching the comment
, commentPageComment :: Comment -- ^ The comment
, muser :: Maybe User -- ^ Viewer
, canComment :: Bool -- ^ true if the user is authorized to comment
}
instance ToJSON CommentPage where
toJSON cp = toJSON (commentPageComment cp)
@ -83,7 +84,7 @@ instance H.ToMarkup CommentPage where
H.text " for "
extlink sl sl
displayComment commentPageComment commentPageViewTime (pure ())
commentForm sl muser (Just (cvt cid))
commentForm sl (fmap (nick . val) muser) (Just (cvt cid))
-- * Created Comment Page
@ -131,14 +132,15 @@ instance H.ToMarkup CommentsPage where
H.h2 $ do
H.text "Comments for "
H.a ! A.href (cvt url) $ H.text url
commentForm url muser Nothing
commentForm url (fmap (nick . val) muser) Nothing
H.ul $ traverse_ (showChildren comments viewTime) (IxSet.toList roots)
commentForm :: StringConv a [Char] => a -> Maybe User -> Maybe H.AttributeValue -> H.Html
commentForm _ Nothing _ = H.div (H.i (H.text "Please login to comment."))
commentForm slug (Just user) mparent =
commentForm :: StringConv a [Char] => Bool -> a -> Maybe Text -> Maybe H.AttributeValue -> H.Html
commentForm False _ _ = H.div (H.i (H.text "Please login to comment."))
commentForm True slug Nothing mparent = commentForm True slug "anonymous coward" mparent
commentForm True slug (Just userNick) mparent =
H.form ! A.action "/comments" ! A.method "post" $ do
H.input ! A.type_ "hidden" ! A.name "userid" ! A.value (cvt (nick (val user)))
H.input ! A.type_ "hidden" ! A.name "userid" ! A.value (cvt userNick)
H.input ! A.type_ "hidden" ! A.name "parent" ! A.value (fromMaybe "" mparent)
H.input ! A.type_ "hidden" ! A.name "slug" ! A.value (cvt slug)
(H.textarea ! A.name "content" ! A.rows "6" ! A.cols "60" ! A.maxlength "5000") ""

56
src/Aggreact/Scopes.hs Normal file
View file

@ -0,0 +1,56 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE NamedWildCards #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{- |
Module : Aggreact.Scopes
Description : Example of a library file.
Copyright : (c) 2018, Yann Esposito
License : ISC
Maintainer : yann.esposito@gmail.com
Stability : experimental
Portability : POSIX
This module export different authorization strategies.
Depending on the user provide different trust mechanism
-}
module Aggreact.Scopes
( Scope (..)
, Scopes
, Access (..)
)
where
import Protolude
import Data.Data (Data (..))
data Scope = Scope { resource :: Text
, access :: Access }
deriving (Eq, Ord, Data, Typeable, Generic, Show)
data Access = Read | Write
deriving (Eq, Ord, Data, Typeable, Generic, Show)
type Scopes = Set Scope

10
src/Aggreact/User.hs
View file

@ -42,13 +42,15 @@ where
import Protolude hiding (pass)
import Aggreact.Authorization (Scopes)
import Aggreact.Scopes (Access (..), Scope (..), Scopes)
import Aggreact.Html (boilerplate, cvt, urlEncode)
import qualified Crypto.Scrypt as Crypt
import Data.Aeson (FromJSON (..), ToJSON (..))
import Data.Data (Data (..))
import qualified Data.Set as Set
import qualified Data.UUID as UUID
import Database.SQLite.Simple (NamedParam (..),
SQLData (..))
@ -114,8 +116,12 @@ instance StringConv Email Text where strConv l (Email sl) = strConv l sl
instance (ToSQLiteFieldTypeList rest) => ToSQLiteFieldTypeList (Email ': rest) where
toSqliteTypes _ = "TEXT":toSqliteTypes (Proxy :: Proxy rest)
adminScopes = Set.fromList [ Scope "user" Write
, Scope "comment" Write
, Scope "admin" Write ]
defaultAdminUser :: NewUser
defaultAdminUser = NewUser { role = Admin
defaultAdminUser = NewUser { scopes = adminScopes
, nick = Nick "admin"
, email = Email "admin@dev.null"
, password = HashedPassword "admin"}