diff --git a/src/.stack-work/intero/intero34QmaL-STAGING.hs b/src/.stack-work/intero/intero34QmaL-STAGING.hs new file mode 100644 index 0000000..4688200 --- /dev/null +++ b/src/.stack-work/intero/intero34QmaL-STAGING.hs @@ -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 diff --git a/src/.stack-work/intero/intero7l3oJR-TEMP.hs b/src/.stack-work/intero/intero7l3oJR-TEMP.hs new file mode 100644 index 0000000..e69de29 diff --git a/src/.stack-work/intero/interoiVdWfA-TEMP.hs b/src/.stack-work/intero/interoiVdWfA-TEMP.hs new file mode 100644 index 0000000..4688200 --- /dev/null +++ b/src/.stack-work/intero/interoiVdWfA-TEMP.hs @@ -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 diff --git a/src/.stack-work/intero/interoqO1nqM-STAGING.hs b/src/.stack-work/intero/interoqO1nqM-STAGING.hs new file mode 100644 index 0000000..4688200 --- /dev/null +++ b/src/.stack-work/intero/interoqO1nqM-STAGING.hs @@ -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 diff --git a/src/Aggreact/Authorization.hs b/src/Aggreact/Authorization.hs index f2b0ec5..2b8f614 100644 --- a/src/Aggreact/Authorization.hs +++ b/src/Aggreact/Authorization.hs @@ -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 = diff --git a/src/Aggreact/Comments/Views.hs b/src/Aggreact/Comments/Views.hs index ec7d3cd..ddd8411 100644 --- a/src/Aggreact/Comments/Views.hs +++ b/src/Aggreact/Comments/Views.hs @@ -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") "" diff --git a/src/Aggreact/Scopes.hs b/src/Aggreact/Scopes.hs new file mode 100644 index 0000000..b21a7c7 --- /dev/null +++ b/src/Aggreact/Scopes.hs @@ -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 diff --git a/src/Aggreact/User.hs b/src/Aggreact/User.hs index 3a7b748..affc6dd 100644 --- a/src/Aggreact/User.hs +++ b/src/Aggreact/User.hs @@ -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"}