added notion of authorizations strategies

aggreact.cabal

@@ -2,7 +2,7 @@
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: ec76b06d212428d6ff4f3f2daa7d453c6af2a54687257bb60e02c5f738d12e1d
+-- hash: 2c0743c70d80e2ac0827c17be0cfb1ca6bfd0a613a186d520ce3faeddd522550
 
 name:           aggreact
 version:        0.1.0.0
@@ -29,6 +29,7 @@ library
   exposed-modules:
       Aggreact
       Aggreact.Auth
+      Aggreact.Authorization
       Aggreact.Comments
       Aggreact.Comments.Server
       Aggreact.Comments.StoreService

src-exe/Main.hs

@@ -1,6 +1,6 @@
 import           Protolude
 
-import           Aggreact  (mainServe,Conf(..))
+import           Aggreact  (mainServe,Conf(..),AuthorizationStrategy(..))
 import           Database.Store.Backend.SQLite  (DBConf (SQLiteConf))
 import           Servant.Auth.Server
 
@@ -14,5 +14,6 @@ main = do
                                      , cookieSameSite = AnySite }
                   , userDBConf = SQLiteConf "aggreact.db" "users"
                   , commentDBConf = SQLiteConf "aggreact.db" "comments"
+                  , authorizationStrategy = Anybody
                   }
   mainServe conf

src/Aggreact.hs

@@ -1,9 +1,9 @@
 {-# LANGUAGE DataKinds             #-}
+{-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE FlexibleInstances     #-}
 {-# LANGUAGE Strict                #-}
 {-# LANGUAGE TypeOperators         #-}
 {-# LANGUAGE TypeSynonymInstances  #-}
-{-# LANGUAGE DuplicateRecordFields #-}
 
 -- Common
 {-# LANGUAGE BlockArguments        #-}
@@ -35,6 +35,7 @@ module Aggreact
     -- * Exported functions
     mainServe
   , Conf (..)
+  , AuthorizationStrategy (..)
   , initialize
   , shutdownApp
   ) where
@@ -42,14 +43,15 @@ module Aggreact
 import           Protolude
 
 import           Aggreact.Auth
+import           Aggreact.Authorization
 import           Aggreact.Comments
 import           Aggreact.Homepage
 import           Aggreact.User
 
-import           Network.Wai                   (Application)
+import           Network.Wai              (Application)
+import           Network.Wai.Handler.Warp (run)
 import           Servant
 import           Servant.Auth.Server
-import           Network.Wai.Handler.Warp      (run)
 
 data Conf =
   Conf
@@ -58,6 +60,7 @@ data Conf =
   , cookieSettings :: CookieSettings
   , userDBConf     :: UserDBConf
   , commentDBConf  :: CommentDBConf
+  , authorizationStrategy :: AuthorizationStrategy
   } deriving (Eq, Show)
 
 type API auths =
@@ -74,7 +77,7 @@ serverAuthenticated :: Settings
                     -> Server Authenticated
 serverAuthenticated Settings{..} authresult =
        homepageAPI commentHandler authresult
-  :<|> commentAPI (Aggreact.Comments.Handlers userHandler commentHandler) authresult
+  :<|> commentAPI (Aggreact.Comments.Handlers userHandler commentHandler authorizationHandler) authresult
   :<|> userAPI userHandler authresult
 
 data Settings =
@@ -82,6 +85,7 @@ data Settings =
            , jwtSettings    :: JWTSettings
            , userHandler    :: UserHandler
            , commentHandler :: CommentHandler
+           , authorizationHandler :: AuthorizationHandler
            }
 
 server :: Settings -> Server (API auths)
@@ -100,6 +104,7 @@ 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
@@ -109,6 +114,7 @@ initialize Conf{..} = do
                  , cookieSettings = cookieSettings
                  , userHandler = uh
                  , commentHandler = ch
+                 , authorizationHandler = ah
                  }
   return ( settings
          , serveWithContext api cfg (server settings))

src/Aggreact/Authorization.hs

@@ -0,0 +1,69 @@
+{-# LANGUAGE BlockArguments        #-}
+{-# LANGUAGE DerivingStrategies    #-}
+{-# LANGUAGE ExplicitForAll        #-}
+{-# LANGUAGE FlexibleContexts      #-}
+{-# LANGUAGE NamedWildCards        #-}
+{-# LANGUAGE NoImplicitPrelude     #-}
+{-# LANGUAGE NumericUnderscores    #-}
+{-# LANGUAGE OverloadedLists       #-}
+{-# LANGUAGE OverloadedStrings     #-}
+{-# LANGUAGE PartialTypeSignatures #-}
+{-# LANGUAGE ScopedTypeVariables   #-}
+{- |
+Module      : Aggreact.Authorization
+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.Authorization
+  ( AuthorizationStrategy (..)
+  , AuthorizationHandler (..)
+  , newAuthorizationHandler
+  )
+where
+
+import           Protolude
+
+import           Aggreact.User  (User)
+
+import           Servant        (Handler)
+import           Servant.Errors (forbidden)
+
+data AuthorizationStrategy =
+  Anybody
+  | LoggedInOnly
+  | ProgressiveTrust
+  deriving (Eq, Show)
+
+newtype AuthorizationHandler =
+  AuthorizationHandler
+  { checkAccess :: Maybe User -> Handler Trust
+  }
+
+data Trust =
+  Bad | New | Observation | Trusted
+  deriving (Eq,Ord,Show)
+
+newAuthorizationHandler :: AuthorizationStrategy -> IO AuthorizationHandler
+newAuthorizationHandler as = pure
+  AuthorizationHandler
+  { checkAccess = _checkAccess as
+  }
+
+_checkAccess :: AuthorizationStrategy -> Maybe User -> Handler Trust
+_checkAccess Anybody _ = pure Trusted
+
+_checkAccess LoggedInOnly Nothing = forbidden "You must log in"
+
+_checkAccess LoggedInOnly (Just _) = pure Trusted
+
+_checkAccess ProgressiveTrust Nothing = forbidden "You must log in"
+_checkAccess ProgressiveTrust (Just _)  = pure Trusted

src/Aggreact/Comments/Server.hs

@@ -39,6 +39,7 @@ import Aggreact.Comments.Types
 import Aggreact.Comments.StoreService (CommentHandler(..))
 import Aggreact.Comments.Views
 import Aggreact.User (UserHandler(..),User)
+import Aggreact.Authorization (AuthorizationHandler(..))
 
 --------------------------------------------------------------------------------
 import           Data.Time                     (getCurrentTime)
@@ -63,8 +64,9 @@ type CommentAPI =
        :> Get '[HTML,JSON] CommentPage
 
 data Handlers =
-  Handlers { userHandler    :: UserHandler
-           , commentHandler :: CommentHandler
+  Handlers { userHandler          :: UserHandler
+           , commentHandler       :: CommentHandler
+           , authorizationHandler :: AuthorizationHandler
            }
 
 commentAPI :: Handlers -> AuthResult User -> Server CommentAPI

src/DevelMain.hs

@@ -18,7 +18,8 @@ module DevelMain where
 
 import           Protolude
 
-import           Aggreact                      (Conf (..), initialize,
+import           Aggreact                      (AuthorizationStrategy (..),
+                                                Conf (..), initialize,
                                                 shutdownApp)
 
 import           Control.Concurrent            (MVar, ThreadId, forkIO,
@@ -72,6 +73,7 @@ update = do
                                      , cookieSameSite = AnySite }
                   , userDBConf = SQLiteConf "aggreact.db" "users"
                   , commentDBConf = SQLiteConf "aggreact.db" "comments"
+                  , authorizationStrategy = Anybody
                   }
 
     -- | Start the server in a separate thread.

stack.yaml

@@ -18,7 +18,7 @@
 #
 # resolver: ./custom-snapshot.yaml
 # resolver: https://example.com/snapshots/2018-01-01.yaml
-resolver: lts-13.0
+resolver: lts-13.11
 
 # User packages to be built.
 # Various formats can be used as shown in the example below.