From 244b488d456d6d61cb0d27d9e5281d7af51911a8 Mon Sep 17 00:00:00 2001 From: GitBluub Date: Fri, 18 Feb 2022 15:01:13 +0100 Subject: [PATCH] format: formatted files with fourmolu --- api/Setup.hs | 1 + api/app/Main.hs | 19 ++-- api/src/Api.hs | 39 ++++---- api/src/Api/About.hs | 58 ++++++------ api/src/Api/Auth.hs | 159 ++++++++++++++++++--------------- api/src/Api/OIDC.hs | 23 ++--- api/src/Api/Pipeline.hs | 95 ++++++++++---------- api/src/App.hs | 10 ++- api/src/Config.hs | 42 ++++----- api/src/Core/OIDC.hs | 23 ++--- api/src/Core/Pipeline.hs | 38 ++++---- api/src/Core/Reaction.hs | 34 +++---- api/src/Core/User.hs | 80 ++++++++--------- api/src/Db/Pipeline.hs | 93 ++++++++++--------- api/src/Db/Reaction.hs | 108 ++++++++++++---------- api/src/Db/User.hs | 107 ++++++++++++---------- api/src/Lib.hs | 32 +++---- api/src/OIDC.hs | 10 +-- api/src/OIDC/Discord.hs | 107 ++++++++++++---------- api/src/OIDC/Github.hs | 106 ++++++++++++---------- api/src/OIDC/Google.hs | 86 ++++++++++-------- api/src/OIDC/Spotify.hs | 115 +++++++++++++----------- api/src/OIDC/Twitter.hs | 115 +++++++++++++----------- api/src/Password.hs | 27 +++--- api/src/Repository.hs | 10 +-- api/src/Repository/Pipeline.hs | 10 +-- api/src/Repository/Reaction.hs | 17 ++-- api/src/Repository/User.hs | 16 ++-- api/src/Repository/Utils.hs | 17 ++-- api/src/Utils.hs | 12 +-- api/test/Spec.hs | 24 +---- 31 files changed, 873 insertions(+), 760 deletions(-) diff --git a/api/Setup.hs b/api/Setup.hs index 9a994af..e8ef27d 100644 --- a/api/Setup.hs +++ b/api/Setup.hs @@ -1,2 +1,3 @@ import Distribution.Simple + main = defaultMain diff --git a/api/app/Main.hs b/api/app/Main.hs index 5d55f8b..6d415f7 100644 --- a/api/app/Main.hs +++ b/api/app/Main.hs @@ -1,23 +1,24 @@ {-# LANGUAGE BlockArguments #-} {-# LANGUAGE OverloadedStrings #-} + module Main where -import qualified Hasql.Connection as Connection -import Rel8(each, select, insert) import Control.Monad.IO.Class (liftIO) -import Servant.Auth.Server (defaultJWTSettings, defaultCookieSettings, generateKey, JWTSettings, CookieSettings) +import qualified Hasql.Connection as Connection import Hasql.Pool (acquire) -import Hasql.Transaction ( Transaction, condemn, statement, sql ) +import Hasql.Transaction (Transaction, condemn, sql, statement) +import Rel8 (each, insert, select) import Servant +import Servant.Auth.Server (CookieSettings, JWTSettings, defaultCookieSettings, defaultJWTSettings, generateKey) -import Network.Wai -import Network.Wai.Handler.Warp +import App +import Config (dbConfigToConnSettings, getPostgresConfig) import qualified Hasql.Session as Session import qualified Hasql.Transaction.Sessions as Hasql -import System.Environment.MrEnv ( envAsBool, envAsInt, envAsInteger, envAsString ) -import App import Lib -import Config (getPostgresConfig, dbConfigToConnSettings) +import Network.Wai +import Network.Wai.Handler.Warp +import System.Environment.MrEnv (envAsBool, envAsInt, envAsInteger, envAsString) main :: IO () main = do diff --git a/api/src/Api.hs b/api/src/Api.hs index 8c760eb..c371c6c 100644 --- a/api/src/Api.hs +++ b/api/src/Api.hs @@ -1,40 +1,41 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE TypeOperators #-} module Api where -import Servant.Auth.Server (CookieSettings, JWTSettings, JWT) -import Servant.API.Generic (type (:-), ToServantApi) -import Servant ( JSON, NamedRoutes, RemoteHost, type (:>), Get, HasServer (ServerT), Handler ) import GHC.Generics (Generic) +import Servant (Get, Handler, HasServer (ServerT), JSON, NamedRoutes, RemoteHost, type (:>)) +import Servant.API.Generic (ToServantApi, type (:-)) +import Servant.Auth.Server (CookieSettings, JWT, JWTSettings) -import Api.Auth import Api.About +import Api.Auth -import Db.User ( User' ) +import Db.User (User') import Api.Pipeline -import App -import Control.Monad.Trans.Reader (ReaderT(runReaderT)) import qualified Api.Pipeline as Api +import App +import Control.Monad.Trans.Reader (ReaderT (runReaderT)) data API mode = API { about :: mode :- "about.json" :> RemoteHost :> Get '[JSON] About - , auth :: mode :- "auth" :> NamedRoutes AuthAPI + , auth :: mode :- "auth" :> NamedRoutes AuthAPI , pipelines :: mode :- "workflow" :> NamedRoutes PipelineAPI - } deriving stock Generic + } + deriving stock (Generic) type NamedAPI = NamedRoutes API - server :: CookieSettings -> JWTSettings -> ServerT NamedAPI AppM -server cs jwts = API - { Api.about = Api.About.about - , Api.auth = Api.Auth.authHandler cs jwts - , Api.pipelines = Api.Pipeline.pipelineHandler - } +server cs jwts = + API + { Api.about = Api.About.about + , Api.auth = Api.Auth.authHandler cs jwts + , Api.pipelines = Api.Pipeline.pipelineHandler + } nt :: State -> AppM a -> Handler a -nt s x = runReaderT x s \ No newline at end of file +nt s x = runReaderT x s diff --git a/api/src/Api/About.hs b/api/src/Api/About.hs index 16a4384..e1a5081 100644 --- a/api/src/Api/About.hs +++ b/api/src/Api/About.hs @@ -1,46 +1,52 @@ -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + {-# HLINT ignore "Use newtype instead of data" #-} module Api.About where -import Data.Aeson ( eitherDecode, defaultOptions ) -import Data.Aeson.TH ( deriveJSON ) -import Data.Time.Clock.POSIX (getPOSIXTime, POSIXTime) -import qualified Data.Aeson.Parser -import Servant (Handler, RemoteHost) -import Control.Monad.IO.Class (liftIO) -import qualified Data.ByteString.Lazy as B -import Network.Socket (SockAddr) -import GHC.Generics ( Generic ) import App (AppM) +import Control.Monad.IO.Class (liftIO) +import Data.Aeson (defaultOptions, eitherDecode) +import qualified Data.Aeson.Parser +import Data.Aeson.TH (deriveJSON) +import qualified Data.ByteString.Lazy as B +import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime) +import GHC.Generics (Generic) +import Network.Socket (SockAddr) +import Servant (Handler, RemoteHost) data ClientAbout = ClientAbout - { host :: String - } deriving (Eq, Show) + { host :: String + } + deriving (Eq, Show) data ActionAbout = ActionAbout - { name :: String - , description :: String - } deriving (Eq, Show) + { name :: String + , description :: String + } + deriving (Eq, Show) data ServicesAbout = ServicesAbout - { name :: String - , actions :: [ActionAbout] - , reactions :: [ActionAbout] - } deriving (Eq, Show, Generic) + { name :: String + , actions :: [ActionAbout] + , reactions :: [ActionAbout] + } + deriving (Eq, Show, Generic) data ServerAbout = ServerAbout - { current_time :: POSIXTime - , services :: [ServicesAbout] - } deriving (Eq, Show) + { current_time :: POSIXTime + , services :: [ServicesAbout] + } + deriving (Eq, Show) data About = About - { client :: ClientAbout, - server :: ServerAbout - } deriving (Eq, Show) + { client :: ClientAbout + , server :: ServerAbout + } + deriving (Eq, Show) $(deriveJSON defaultOptions ''ClientAbout) $(deriveJSON defaultOptions ''ActionAbout) @@ -55,4 +61,4 @@ about host = do d <- liftIO ((eitherDecode <$> B.readFile "services.json") :: IO (Either String [ServicesAbout])) case d of Left err -> return $ About (ClientAbout $ show host) (ServerAbout now []) - Right services -> return $ About (ClientAbout $ show host) (ServerAbout now services) \ No newline at end of file + Right services -> return $ About (ClientAbout $ show host) (ServerAbout now services) diff --git a/api/src/Api/Auth.hs b/api/src/Api/Auth.hs index 77e8111..730f726 100644 --- a/api/src/Api/Auth.hs +++ b/api/src/Api/Auth.hs @@ -1,49 +1,53 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE TypeOperators #-} + module Api.Auth where -import Servant - ( err401, - throwError, - type (:<|>)(..), - JSON, - NoContent(..), - Header, - NamedRoutes, - ReqBody, - Headers, - type (:>), - Get, - Post, - HasServer(ServerT) ) +import Servant ( + Get, + HasServer (ServerT), + Header, + Headers, + JSON, + NamedRoutes, + NoContent (..), + Post, + ReqBody, + err401, + throwError, + type (:<|>) (..), + type (:>), + ) -import qualified Servant.Auth.Server -import Servant.Auth.Server (ThrowAll(throwAll), SetCookie, CookieSettings, JWTSettings, acceptLogin, JWT) import Control.Monad.IO.Class (liftIO) -import Db.User ( User', password, UserDB (UserDB), toUser ) -import GHC.Generics ( Generic ) -import Servant.API.Generic ((:-), ToServantApi) -import Data.Aeson (ToJSON, FromJSON) +import Data.Aeson (FromJSON, ToJSON) +import Db.User (User', UserDB (UserDB), password, toUser) +import GHC.Generics (Generic) +import Servant.API.Generic (ToServantApi, (:-)) +import Servant.Auth.Server (CookieSettings, JWT, JWTSettings, SetCookie, ThrowAll (throwAll), acceptLogin) +import qualified Servant.Auth.Server import Servant.Server.Generic (AsServerT) +import Api.OIDC (OauthAPI, oauth) import App (AppM) +import Core.User (User, UserId (UserId)) import Data.Text (pack) import Password (hashPassword'', toPassword, validatePassword') -import Core.User (UserId(UserId), User) -import Repository (getUserByName', createUser) -import Api.OIDC (OauthAPI, oauth) +import Repository (createUser, getUserByName') data LoginUser = LoginUser - { loginUsername :: String - , loginPassword :: String - } deriving (Eq, Show, Read, Generic) + { loginUsername :: String + , loginPassword :: String + } + deriving (Eq, Show, Read, Generic) data SignupUser = SignupUser - { signupUsername :: String - , signupPassword :: String - } deriving (Eq, Show, Read, Generic) + { signupUsername :: String + , signupPassword :: String + } + deriving (Eq, Show, Read, Generic) instance ToJSON LoginUser instance FromJSON LoginUser @@ -51,62 +55,69 @@ instance FromJSON LoginUser instance ToJSON SignupUser instance FromJSON SignupUser -type Protected - = "me" :> Get '[JSON] User +type Protected = + "me" :> Get '[JSON] User protected :: Servant.Auth.Server.AuthResult User' -> ServerT Protected AppM protected (Servant.Auth.Server.Authenticated user) = return $ toUser user protected _ = throwAll err401 -type Unprotected - = "login" - :> ReqBody '[JSON] LoginUser - :> Post '[JSON] (Headers '[Header "Set-Cookie" SetCookie, Header "Set-Cookie" SetCookie] NoContent) - :<|> "signup" - :> ReqBody '[JSON] SignupUser - :> Post '[JSON] NoContent +type Unprotected = + "login" + :> ReqBody '[JSON] LoginUser + :> Post '[JSON] (Headers '[Header "Set-Cookie" SetCookie, Header "Set-Cookie" SetCookie] NoContent) + :<|> "signup" + :> ReqBody '[JSON] SignupUser + :> Post '[JSON] NoContent -loginHandler :: CookieSettings - -> JWTSettings - -> LoginUser - -> AppM (Headers '[Header "Set-Cookie" SetCookie, Header "Set-Cookie" SetCookie] NoContent) +loginHandler :: + CookieSettings -> + JWTSettings -> + LoginUser -> + AppM (Headers '[Header "Set-Cookie" SetCookie, Header "Set-Cookie" SetCookie] NoContent) loginHandler cs jwts (LoginUser username p) = do - users' <- getUserByName' $ pack username - let usr = head users' - if validatePassword' (toPassword $ pack p) (password usr) then do - mApplyCookies <- liftIO $ acceptLogin cs jwts usr - case mApplyCookies of - Nothing -> throwError err401 - Just applyCookies -> return $ applyCookies NoContent - else - throwError err401 + users' <- getUserByName' $ pack username + let usr = head users' + if validatePassword' (toPassword $ pack p) (password usr) + then do + mApplyCookies <- liftIO $ acceptLogin cs jwts usr + case mApplyCookies of + Nothing -> throwError err401 + Just applyCookies -> return $ applyCookies NoContent + else throwError err401 -signupHandler :: SignupUser - -> AppM NoContent +signupHandler :: + SignupUser -> + AppM NoContent signupHandler (SignupUser name p) = do - hashed <- hashPassword'' $ toPassword $ pack p - usr <- createUser $ UserDB (UserId 1) (pack name) hashed (pack name) [] - return NoContent + hashed <- hashPassword'' $ toPassword $ pack p + usr <- createUser $ UserDB (UserId 1) (pack name) hashed (pack name) [] + return NoContent unprotected :: CookieSettings -> JWTSettings -> ServerT Unprotected AppM unprotected cs jwts = - loginHandler cs jwts - :<|> signupHandler + loginHandler cs jwts + :<|> signupHandler data AuthAPI mode = AuthAPI - { - protectedApi :: mode - :- (Servant.Auth.Server.Auth '[JWT] User' - :> Protected) - , unprotectedApi :: mode - :- Unprotected - , oauthApi :: mode - :- OauthAPI - } deriving stock Generic + { protectedApi :: + mode + :- ( Servant.Auth.Server.Auth '[JWT] User' + :> Protected + ) + , unprotectedApi :: + mode + :- Unprotected + , oauthApi :: + mode + :- OauthAPI + } + deriving stock (Generic) authHandler :: CookieSettings -> JWTSettings -> AuthAPI (AsServerT AppM) -authHandler cs jwts = AuthAPI - { protectedApi = protected - , unprotectedApi = unprotected cs jwts - , oauthApi = oauth - } \ No newline at end of file +authHandler cs jwts = + AuthAPI + { protectedApi = protected + , unprotectedApi = unprotected cs jwts + , oauthApi = oauth + } diff --git a/api/src/Api/OIDC.hs b/api/src/Api/OIDC.hs index 8539771..e6d5c97 100644 --- a/api/src/Api/OIDC.hs +++ b/api/src/Api/OIDC.hs @@ -1,19 +1,20 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeOperators #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeOperators #-} + module Api.OIDC where -import OIDC -import Servant (NoContent (NoContent), type (:>), JSON, Get, ServerT, type (:<|>) ((:<|>)), QueryParam, throwError, err400, Capture, GetNoContent) -import Servant.Server.Generic (AsServerT) import App (AppM) -import Servant.API.Generic (type (:-)) import Control.Monad.IO.Class (liftIO) -import Core.User (UserId(UserId), ExternalToken (ExternalToken, service), Service (Github)) -import Repository.User (updateTokens) +import Core.User (ExternalToken (ExternalToken, service), Service (Github), UserId (UserId)) import Data.Text (pack) +import OIDC +import Repository.User (updateTokens) +import Servant (Capture, Get, GetNoContent, JSON, NoContent (NoContent), QueryParam, ServerT, err400, throwError, type (:<|>) ((:<|>)), type (:>)) +import Servant.API.Generic (type (:-)) +import Servant.Server.Generic (AsServerT) -oauthHandler :: Service -> Maybe String -> AppM NoContent +oauthHandler :: Service -> Maybe String -> AppM NoContent oauthHandler service (Just code) = do tokens <- liftIO $ getOauthTokens service code case tokens of @@ -21,8 +22,8 @@ oauthHandler service (Just code) = do Just t -> do updateTokens (UserId 1) t return NoContent -oauthHandler _ _ = throwError err400 +oauthHandler _ _ = throwError err400 -type OauthAPI = Capture "service" Service :> QueryParam "code" String :> Get '[JSON] NoContent +type OauthAPI = Capture "service" Service :> QueryParam "code" String :> Get '[JSON] NoContent oauth :: ServerT OauthAPI AppM -oauth = oauthHandler \ No newline at end of file +oauth = oauthHandler diff --git a/api/src/Api/Pipeline.hs b/api/src/Api/Pipeline.hs index 0b8f5b2..eb701ab 100644 --- a/api/src/Api/Pipeline.hs +++ b/api/src/Api/Pipeline.hs @@ -1,49 +1,49 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE BlockArguments #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE TypeOperators #-} module Api.Pipeline where -import Servant (Capture, Get, type (:>), JSON, throwError, err401) -import Servant.API.Generic ((:-)) -import GHC.Generics (Generic) -import Data.Int (Int64) -import Db.Pipeline (Pipeline (Pipeline, pipelineType), pipelineSchema, getPipelineById, PipelineId (PipelineId, toInt64), insertPipeline, pipelineParams, pipelineName) -import Data.Functor.Identity (Identity) -import Servant.API (Post, Delete, Put, ReqBody) import App (AppM, State (State, dbPool)) -import Servant.Server.Generic (AsServerT) -import Hasql.Statement (Statement) import Control.Monad.IO.Class (MonadIO) import Control.Monad.Trans.Reader (ask) -import Data.Aeson ( eitherDecode, defaultOptions, FromJSON, ToJSON ) +import Core.Pipeline (PipelineParams, PipelineType) +import Core.Reaction (ReactionParams, ReactionType) +import Data.Aeson (FromJSON, ToJSON, defaultOptions, eitherDecode) import Data.Aeson.TH (deriveJSON) -import Hasql.Transaction (Transaction, statement) -import Rel8 (select, each, insert, orderBy, asc, limit) -import Core.Reaction (ReactionType, ReactionParams) -import Core.Pipeline (PipelineType, PipelineParams) +import Data.Functor.Identity (Identity) +import Data.Int (Int64) import Data.Text (Text) -import Db.Reaction (Reaction (Reaction, reactionOrder, reactionParams, reactionType), ReactionId (ReactionId), insertReaction, getReactionsByPipelineId) -import Utils (mapInd) +import Db.Pipeline (Pipeline (Pipeline, pipelineType), PipelineId (PipelineId, toInt64), getPipelineById, insertPipeline, pipelineName, pipelineParams, pipelineSchema) +import Db.Reaction (Reaction (Reaction, reactionOrder, reactionParams, reactionType), ReactionId (ReactionId), getReactionsByPipelineId, insertReaction) +import GHC.Generics (Generic) +import Hasql.Statement (Statement) +import Hasql.Transaction (Transaction, statement) +import Rel8 (asc, each, insert, limit, orderBy, select) import Repository +import Servant (Capture, Get, JSON, err401, throwError, type (:>)) +import Servant.API (Delete, Post, Put, ReqBody) +import Servant.API.Generic ((:-)) +import Servant.Server.Generic (AsServerT) +import Utils (mapInd) data PipelineData = PipelineData - { pipelineDataName :: Text - , pipelineDataType :: PipelineType - , pipelineDataParams :: PipelineParams + { pipelineDataName :: Text + , pipelineDataType :: PipelineType + , pipelineDataParams :: PipelineParams } data ReactionData = ReactionData - { reactionDataType :: ReactionType - , reactionDataParams :: ReactionParams + { reactionDataType :: ReactionType + , reactionDataParams :: ReactionParams } data PostPipelineData = PostPipelineData - { action :: PipelineData + { action :: PipelineData , reactions :: [ReactionData] } @@ -54,32 +54,32 @@ $(deriveJSON defaultOptions ''ReactionData) $(deriveJSON defaultOptions ''PostPipelineData) data PipelineAPI mode = PipelineAPI - { get :: mode :- Capture "id" PipelineId :> Get '[JSON] GetPipelineResponse - , post :: mode :- ReqBody '[JSON] PostPipelineData :> Post '[JSON] [ReactionId] - , put :: mode :- Capture "id" PipelineId :> Put '[JSON] (Pipeline Identity) - , del :: mode :- Capture "id" PipelineId :> Delete '[JSON] (Pipeline Identity) - } deriving stock Generic + { get :: mode :- Capture "id" PipelineId :> Get '[JSON] GetPipelineResponse + , post :: mode :- ReqBody '[JSON] PostPipelineData :> Post '[JSON] [ReactionId] + , put :: mode :- Capture "id" PipelineId :> Put '[JSON] (Pipeline Identity) + , del :: mode :- Capture "id" PipelineId :> Delete '[JSON] (Pipeline Identity) + } + deriving stock (Generic) - -getPipelineHandler :: PipelineId -> AppM GetPipelineResponse +getPipelineHandler :: PipelineId -> AppM GetPipelineResponse getPipelineHandler pipelineId = do pipeline <- getPipelineById' pipelineId reactions <- getReactionsByPipelineId' pipelineId let actionResult = PipelineData (pipelineName pipeline) (pipelineType pipeline) (pipelineParams pipeline) - let reactionsResult = fmap (\x -> ReactionData (reactionType x) (reactionParams x)) reactions + let reactionsResult = fmap (\x -> ReactionData (reactionType x) (reactionParams x)) reactions return $ PostPipelineData actionResult reactionsResult postPipelineHandler :: PostPipelineData -> AppM [ReactionId] postPipelineHandler x = do actionId <- createPipeline $ Pipeline (PipelineId 1) (pipelineDataName p) (pipelineDataType p) (pipelineDataParams p) sequence $ mapInd (reactionMap (head actionId)) r - where - p = action x - r = reactions x - reactionMap :: PipelineId -> ReactionData -> Int -> AppM ReactionId - reactionMap actionId s i = do - res <- createReaction $ Reaction (ReactionId 1) (reactionDataType s) (reactionDataParams s) actionId (fromIntegral i) - return $ head res + where + p = action x + r = reactions x + reactionMap :: PipelineId -> ReactionData -> Int -> AppM ReactionId + reactionMap actionId s i = do + res <- createReaction $ Reaction (ReactionId 1) (reactionDataType s) (reactionDataParams s) actionId (fromIntegral i) + return $ head res putPipelineHandler :: PipelineId -> AppM (Pipeline Identity) putPipelineHandler pipelineId = throwError err401 @@ -88,9 +88,10 @@ delPipelineHandler :: PipelineId -> AppM (Pipeline Identity) delPipelineHandler pipelineId = throwError err401 pipelineHandler :: PipelineAPI (AsServerT AppM) -pipelineHandler = PipelineAPI - { get = getPipelineHandler - , post = postPipelineHandler - , put = putPipelineHandler - , del = delPipelineHandler - } \ No newline at end of file +pipelineHandler = + PipelineAPI + { get = getPipelineHandler + , post = postPipelineHandler + , put = putPipelineHandler + , del = delPipelineHandler + } diff --git a/api/src/App.hs b/api/src/App.hs index 994f9a4..768e62c 100644 --- a/api/src/App.hs +++ b/api/src/App.hs @@ -1,14 +1,16 @@ +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} +{-# HLINT ignore "Use newtype instead of data" #-} module App where +import Control.Monad.Trans.Reader (ReaderT, ask, runReaderT) import Hasql.Pool (Pool) -import Control.Monad.Trans.Reader (ReaderT, ask, runReaderT) import Servant (Handler) data State = State - { dbPool :: Pool - } + { dbPool :: Pool + } type AppM = ReaderT State Handler nt :: State -> AppM a -> Handler a -nt s x = runReaderT x s \ No newline at end of file +nt s x = runReaderT x s diff --git a/api/src/Config.hs b/api/src/Config.hs index 3770edb..5d76dac 100644 --- a/api/src/Config.hs +++ b/api/src/Config.hs @@ -2,33 +2,35 @@ module Config where -import System.Environment.MrEnv ( envAsBool, envAsInt, envAsInteger, envAsString ) -import qualified Hasql.Connection as Connection import Data.ByteString.Lazy.UTF8 as BLU -- from utf8-string -import Data.Text.Encoding (encodeUtf8) import Data.Text (pack) +import Data.Text.Encoding (encodeUtf8) import Data.Word (Word16) +import qualified Hasql.Connection as Connection +import System.Environment.MrEnv (envAsBool, envAsInt, envAsInteger, envAsString) data DbConfig = DbConfig - { dbPort :: Int - , dbHost :: String - , dbDB :: String - , dbUser :: String - , dbPassword :: String + { dbPort :: Int + , dbHost :: String + , dbDB :: String + , dbUser :: String + , dbPassword :: String } getPostgresConfig :: IO DbConfig -getPostgresConfig = DbConfig - <$> envAsInt "POSTGRES_PORT" 5432 - <*> envAsString "POSTGRES_HOST" "localhost" - <*> envAsString "POSTGRES_DB" "postgres" - <*> envAsString "POSTGRES_USER" "postgres" - <*> envAsString "POSTGRES_PASSWORD" "password" +getPostgresConfig = + DbConfig + <$> envAsInt "POSTGRES_PORT" 5432 + <*> envAsString "POSTGRES_HOST" "localhost" + <*> envAsString "POSTGRES_DB" "postgres" + <*> envAsString "POSTGRES_USER" "postgres" + <*> envAsString "POSTGRES_PASSWORD" "password" dbConfigToConnSettings :: DbConfig -> Connection.Settings -dbConfigToConnSettings (DbConfig port host db user passwd) = Connection.settings - (encodeUtf8 $ pack host) - (fromIntegral port :: Word16) - (encodeUtf8 $ pack user) - (encodeUtf8 $ pack passwd) - (encodeUtf8 $ pack db) +dbConfigToConnSettings (DbConfig port host db user passwd) = + Connection.settings + (encodeUtf8 $ pack host) + (fromIntegral port :: Word16) + (encodeUtf8 $ pack user) + (encodeUtf8 $ pack passwd) + (encodeUtf8 $ pack db) diff --git a/api/src/Core/OIDC.hs b/api/src/Core/OIDC.hs index 9a24071..9d85fc8 100644 --- a/api/src/Core/OIDC.hs +++ b/api/src/Core/OIDC.hs @@ -1,19 +1,22 @@ {-# LANGUAGE OverloadedStrings #-} module Core.OIDC where + import Data.ByteString.Lazy -- * OIDC -data OIDCConf = - OIDCConf { redirectUri :: ByteString - , clientId :: ByteString - , clientPassword :: ByteString - } deriving (Show, Eq) +data OIDCConf = OIDCConf + { redirectUri :: ByteString + , clientId :: ByteString + , clientPassword :: ByteString + } + deriving (Show, Eq) oidcGoogleConf :: OIDCConf -oidcGoogleConf = OIDCConf - { redirectUri = "http://localhost:8080/auth/login/google" - , clientId = "914790981890-qjn5qjq5qjqjqjqjqjqjqjqjqjqjqjq.apps.googleusercontent.com" - , clientPassword = "914790981890-qjn5qjq5qjqjqjqjqjqjqjqjqjqjqjqjq" - } \ No newline at end of file +oidcGoogleConf = + OIDCConf + { redirectUri = "http://localhost:8080/auth/login/google" + , clientId = "914790981890-qjn5qjq5qjqjqjqjqjqjqjqjqjqjqjq.apps.googleusercontent.com" + , clientPassword = "914790981890-qjn5qjq5qjqjqjqjqjqjqjqjqjqjqjqjq" + } diff --git a/api/src/Core/Pipeline.hs b/api/src/Core/Pipeline.hs index e40e10b..d598d5f 100644 --- a/api/src/Core/Pipeline.hs +++ b/api/src/Core/Pipeline.hs @@ -1,38 +1,42 @@ -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} {-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + {-# HLINT ignore "Use newtype instead of data" #-} module Core.Pipeline where -import GHC.Generics (Generic) -import Rel8 (DBType, ReadShow (ReadShow), JSONBEncoded (JSONBEncoded)) -import Data.Aeson ( eitherDecode, defaultOptions, FromJSON, ToJSON ) -import Data.Text (Text) +import Data.Aeson (FromJSON, ToJSON, defaultOptions, eitherDecode) import Data.Aeson.TH (deriveJSON) +import Data.Text (Text) +import GHC.Generics (Generic) +import Rel8 (DBType, JSONBEncoded (JSONBEncoded), ReadShow (ReadShow)) data PipelineType = TwitterNewPost | TwitterNewFollower - deriving stock (Generic, Read, Show) - deriving DBType via ReadShow PipelineType - deriving (FromJSON, ToJSON) + deriving stock (Generic, Read, Show) + deriving (DBType) via ReadShow PipelineType + deriving (FromJSON, ToJSON) data TwitterNewPostData = TwitterNewPostData - { author :: Text - } deriving (Eq, Show, Generic) + { author :: Text + } + deriving (Eq, Show, Generic) $(deriveJSON defaultOptions ''TwitterNewPostData) data TwitterNewFollowerData = TwitterNewFollowerData - { author :: Text - } deriving (Eq, Show, Generic) + { author :: Text + } + deriving (Eq, Show, Generic) $(deriveJSON defaultOptions ''TwitterNewFollowerData) -data PipelineParams = TwitterNewPostP TwitterNewPostData | - TwitterNewFollowerP TwitterNewFollowerData +data PipelineParams + = TwitterNewPostP TwitterNewPostData + | TwitterNewFollowerP TwitterNewFollowerData deriving stock (Generic, Show) deriving anyclass (ToJSON, FromJSON) - deriving DBType via JSONBEncoded PipelineParams \ No newline at end of file + deriving (DBType) via JSONBEncoded PipelineParams diff --git a/api/src/Core/Reaction.hs b/api/src/Core/Reaction.hs index 8d364fe..ad041c5 100644 --- a/api/src/Core/Reaction.hs +++ b/api/src/Core/Reaction.hs @@ -1,38 +1,40 @@ -{-# LANGUAGE DerivingVia #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} {-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + {-# HLINT ignore "Use newtype instead of data" #-} module Core.Reaction where -import GHC.Generics (Generic) -import Rel8 (ReadShow (ReadShow), DBType, JSONBEncoded(JSONBEncoded)) -import Data.Aeson ( eitherDecode, defaultOptions, FromJSON, ToJSON ) +import Data.Aeson (FromJSON, ToJSON, defaultOptions, eitherDecode) import Data.Aeson.TH (deriveJSON) import Data.Text (Text) - +import GHC.Generics (Generic) +import Rel8 (DBType, JSONBEncoded (JSONBEncoded), ReadShow (ReadShow)) data ReactionType = TwitterTweet | TwitterFollower - deriving stock (Generic, Read, Show) - deriving DBType via ReadShow ReactionType - deriving (FromJSON, ToJSON) + deriving stock (Generic, Read, Show) + deriving (DBType) via ReadShow ReactionType + deriving (FromJSON, ToJSON) data TwitterTweetData = TwitterTweetData - { body :: Text - } deriving (Eq, Show, Generic) + { body :: Text + } + deriving (Eq, Show, Generic) $(deriveJSON defaultOptions ''TwitterTweetData) data TwitterFollowData = TwitterFollowData - { toFollow :: Text - } deriving (Eq, Show, Generic) + { toFollow :: Text + } + deriving (Eq, Show, Generic) $(deriveJSON defaultOptions ''TwitterFollowData) - -data ReactionParams = TwitterTweetP TwitterTweetData | - TwitterFollowP TwitterFollowData +data ReactionParams + = TwitterTweetP TwitterTweetData + | TwitterFollowP TwitterFollowData deriving stock (Generic, Show) deriving anyclass (ToJSON, FromJSON) - deriving DBType via JSONBEncoded ReactionParams \ No newline at end of file + deriving (DBType) via JSONBEncoded ReactionParams diff --git a/api/src/Core/User.hs b/api/src/Core/User.hs index 1b0a035..cd7b0e2 100644 --- a/api/src/Core/User.hs +++ b/api/src/Core/User.hs @@ -1,56 +1,56 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingVia #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} module Core.User where -import GHC.Generics (Generic) -import Data.Text (Text) -import Rel8 (DBType, DBEq, JSONBEncoded (JSONBEncoded)) -import Data.Int (Int64) + +import Data.Aeson (FromJSON, ToJSON, defaultOptions, eitherDecode) import Data.Aeson.TH (deriveJSON) -import Servant.Server.Experimental.Auth (AuthServerData) -import Data.Aeson ( eitherDecode, defaultOptions, FromJSON, ToJSON ) +import Data.Int (Int64) +import Data.Text (Text) +import GHC.Generics (Generic) +import Rel8 (DBEq, DBType, JSONBEncoded (JSONBEncoded)) import Servant (AuthProtect, FromHttpApiData) -import Servant.API (FromHttpApiData(parseUrlPiece)) - - -newtype UserId = UserId { toInt64 :: Int64 } - deriving newtype (DBEq, DBType, Eq, Show, Num, FromJSON, ToJSON) - deriving stock (Generic) +import Servant.API (FromHttpApiData (parseUrlPiece)) +import Servant.Server.Experimental.Auth (AuthServerData) +newtype UserId = UserId {toInt64 :: Int64} + deriving newtype (DBEq, DBType, Eq, Show, Num, FromJSON, ToJSON) + deriving stock (Generic) data Service = Github | Google | Spotify | Twitter | Discord - deriving (Eq, Show, Generic, ToJSON, FromJSON) + deriving (Eq, Show, Generic, ToJSON, FromJSON) instance FromHttpApiData Service where - parseUrlPiece :: Text -> Either Text Service - parseUrlPiece "github" = Right Github - parseUrlPiece "google" = Right Google - parseUrlPiece "spotify" = Right Spotify - parseUrlPiece "twitter" = Right Twitter - parseUrlPiece "discord" = Right Discord - parseUrlPiece _ = Left "not a service" + parseUrlPiece :: Text -> Either Text Service + parseUrlPiece "github" = Right Github + parseUrlPiece "google" = Right Google + parseUrlPiece "spotify" = Right Spotify + parseUrlPiece "twitter" = Right Twitter + parseUrlPiece "discord" = Right Discord + parseUrlPiece _ = Left "not a service" -data ExternalToken = ExternalToken { - accessToken :: Text, - refreshToken :: Text, - expiresIn :: Int64, - service :: Service -} deriving (Eq, Show, Generic) - deriving anyclass (ToJSON, FromJSON) - deriving DBType via JSONBEncoded ExternalToken +data ExternalToken = ExternalToken + { accessToken :: Text + , refreshToken :: Text + , expiresIn :: Int64 + , service :: Service + } + deriving (Eq, Show, Generic) + deriving anyclass (ToJSON, FromJSON) + deriving (DBType) via JSONBEncoded ExternalToken -data User = User - { userId :: UserId - , userName :: Text - , userSlug :: Text - } deriving stock (Generic) +data User = User + { userId :: UserId + , userName :: Text + , userSlug :: Text + } + deriving stock (Generic) - -$(deriveJSON defaultOptions ''User) \ No newline at end of file +$(deriveJSON defaultOptions ''User) diff --git a/api/src/Db/Pipeline.hs b/api/src/Db/Pipeline.hs index 14337b6..39d48c4 100644 --- a/api/src/Db/Pipeline.hs +++ b/api/src/Db/Pipeline.hs @@ -1,37 +1,42 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleInstances #-} - +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} module Db.Pipeline where +import Data.Aeson ( + FromJSON, + ToJSON, + defaultOptions, + eitherDecode, + ) +import Data.Aeson.TH (deriveJSON) import Data.Int (Int64) -import Data.Aeson - ( eitherDecode, defaultOptions, FromJSON, ToJSON ) -import Data.Aeson.TH ( deriveJSON ) -import GHC.Generics (Generic) -import Rel8 (DBEq, DBType, Column, Rel8able, ReadShow (ReadShow), JSONBEncoded (JSONBEncoded), Result, TableSchema (TableSchema, name, schema, columns), Name, Query, Expr, where_, (==.), lit, each, Insert (Insert, returning), into, rows, onConflict, returning, Returning (Projection), OnConflict (DoNothing), values, unsafeCastExpr, nextval) import Data.Text (Text) +import GHC.Generics (Generic) +import Rel8 (Column, DBEq, DBType, Expr, Insert (Insert, returning), JSONBEncoded (JSONBEncoded), Name, OnConflict (DoNothing), Query, ReadShow (ReadShow), Rel8able, Result, Returning (Projection), TableSchema (TableSchema, columns, name, schema), each, into, lit, nextval, onConflict, returning, rows, unsafeCastExpr, values, where_, (==.)) import Core.Pipeline import Data.Functor.Identity (Identity) import Servant (FromHttpApiData) -newtype PipelineId = PipelineId { toInt64 :: Int64 } - deriving newtype (DBEq, DBType, Eq, Show, Num, FromJSON, ToJSON, FromHttpApiData) - deriving stock (Generic) + +newtype PipelineId = PipelineId {toInt64 :: Int64} + deriving newtype (DBEq, DBType, Eq, Show, Num, FromJSON, ToJSON, FromHttpApiData) + deriving stock (Generic) data Pipeline f = Pipeline - { pipelineId :: Column f PipelineId - , pipelineName :: Column f Text - , pipelineType :: Column f PipelineType - , pipelineParams :: Column f PipelineParams - } deriving stock (Generic) + { pipelineId :: Column f PipelineId + , pipelineName :: Column f Text + , pipelineType :: Column f PipelineType + , pipelineParams :: Column f PipelineParams + } + deriving stock (Generic) deriving anyclass (Rel8able) deriving stock instance f ~ Result => Show (Pipeline f) @@ -40,17 +45,18 @@ instance ToJSON (Pipeline Identity) instance FromJSON (Pipeline Identity) pipelineSchema :: TableSchema (Pipeline Name) -pipelineSchema = TableSchema - { name = "pipelines" - , schema = Nothing - , columns = Pipeline - { pipelineId = "id" - , pipelineName = "name" - , pipelineType = "type" - , pipelineParams = "params" - } - } - +pipelineSchema = + TableSchema + { name = "pipelines" + , schema = Nothing + , columns = + Pipeline + { pipelineId = "id" + , pipelineName = "name" + , pipelineType = "type" + , pipelineParams = "params" + } + } selectAllPipelines :: Query (Pipeline Expr) selectAllPipelines = each pipelineSchema @@ -61,16 +67,19 @@ getPipelineById uid = do where_ $ pipelineId u ==. lit uid return u - insertPipeline :: Pipeline Identity -> Insert [PipelineId] -insertPipeline (Pipeline _ name type' params) = Insert - { into = pipelineSchema - , rows = values [ Pipeline { - pipelineId = unsafeCastExpr $ nextval "pipelines_id_seq", - pipelineName = lit name, - pipelineType = lit type', - pipelineParams = lit params - } ] - , onConflict = DoNothing - , returning = Projection pipelineId - } \ No newline at end of file +insertPipeline (Pipeline _ name type' params) = + Insert + { into = pipelineSchema + , rows = + values + [ Pipeline + { pipelineId = unsafeCastExpr $ nextval "pipelines_id_seq" + , pipelineName = lit name + , pipelineType = lit type' + , pipelineParams = lit params + } + ] + , onConflict = DoNothing + , returning = Projection pipelineId + } diff --git a/api/src/Db/Reaction.hs b/api/src/Db/Reaction.hs index 49c52fe..3047ae8 100644 --- a/api/src/Db/Reaction.hs +++ b/api/src/Db/Reaction.hs @@ -1,74 +1,84 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} + module Db.Reaction where -import Data.Aeson - ( eitherDecode, defaultOptions, FromJSON, ToJSON ) -import Data.Aeson.TH ( deriveJSON ) -import GHC.Generics (Generic) -import Rel8 (DBEq, DBType, Column, Rel8able, ReadShow (ReadShow), JSONBEncoded (JSONBEncoded), Result, TableSchema (TableSchema, name, schema, columns), Name, Query, Expr, where_, (==.), lit, each, Insert (Insert, returning), into, rows, onConflict, returning, values, unsafeCastExpr, nextval, OnConflict (DoNothing), Returning (Projection)) -import Data.Text (Text) +import Data.Aeson ( + FromJSON, + ToJSON, + defaultOptions, + eitherDecode, + ) +import Data.Aeson.TH (deriveJSON) import Data.Int (Int64) +import Data.Text (Text) +import GHC.Generics (Generic) +import Rel8 (Column, DBEq, DBType, Expr, Insert (Insert, returning), JSONBEncoded (JSONBEncoded), Name, OnConflict (DoNothing), Query, ReadShow (ReadShow), Rel8able, Result, Returning (Projection), TableSchema (TableSchema, columns, name, schema), each, into, lit, nextval, onConflict, returning, rows, unsafeCastExpr, values, where_, (==.)) -import Db.Pipeline (PipelineId) import Core.Reaction import Data.Functor.Identity (Identity) +import Db.Pipeline (PipelineId) -newtype ReactionId = ReactionId { toInt64 :: Int64 } - deriving newtype (DBEq, DBType, Eq, Show, Num, FromJSON, ToJSON) - deriving stock (Generic) +newtype ReactionId = ReactionId {toInt64 :: Int64} + deriving newtype (DBEq, DBType, Eq, Show, Num, FromJSON, ToJSON) + deriving stock (Generic) data Reaction f = Reaction - { reactionId :: Column f ReactionId - , reactionType :: Column f ReactionType - , reactionParams :: Column f ReactionParams - , reactionPipelineId :: Column f PipelineId - , reactionOrder :: Column f Int64 - } deriving stock (Generic) + { reactionId :: Column f ReactionId + , reactionType :: Column f ReactionType + , reactionParams :: Column f ReactionParams + , reactionPipelineId :: Column f PipelineId + , reactionOrder :: Column f Int64 + } + deriving stock (Generic) deriving anyclass (Rel8able) deriving stock instance f ~ Result => Show (Reaction f) - instance ToJSON (Reaction Identity) instance FromJSON (Reaction Identity) reactionSchema :: TableSchema (Reaction Name) -reactionSchema = TableSchema - { name = "reactions" - , schema = Nothing - , columns = Reaction - { reactionId = "id" - , reactionOrder = "react_order" - , reactionType = "type" - , reactionParams = "params" - , reactionPipelineId = "pipeline_id" - } - } - +reactionSchema = + TableSchema + { name = "reactions" + , schema = Nothing + , columns = + Reaction + { reactionId = "id" + , reactionOrder = "react_order" + , reactionType = "type" + , reactionParams = "params" + , reactionPipelineId = "pipeline_id" + } + } insertReaction :: Reaction Identity -> Insert [ReactionId] -insertReaction (Reaction _ type' params pipeId order) = Insert - { into = reactionSchema - , rows = values [ Reaction { - reactionId = unsafeCastExpr $ nextval "reactions_id_seq", - reactionType = lit type', - reactionParams = lit params, - reactionPipelineId = lit pipeId, - reactionOrder = lit order - } ] - , onConflict = DoNothing - , returning = Projection reactionId - } +insertReaction (Reaction _ type' params pipeId order) = + Insert + { into = reactionSchema + , rows = + values + [ Reaction + { reactionId = unsafeCastExpr $ nextval "reactions_id_seq" + , reactionType = lit type' + , reactionParams = lit params + , reactionPipelineId = lit pipeId + , reactionOrder = lit order + } + ] + , onConflict = DoNothing + , returning = Projection reactionId + } getReactionsByPipelineId :: PipelineId -> Query (Reaction Expr) getReactionsByPipelineId pId = do - r <- each reactionSchema - where_ $ reactionPipelineId r ==. lit pId - return r \ No newline at end of file + r <- each reactionSchema + where_ $ reactionPipelineId r ==. lit pId + return r diff --git a/api/src/Db/User.hs b/api/src/Db/User.hs index 35eb3b1..75cf47e 100644 --- a/api/src/Db/User.hs +++ b/api/src/Db/User.hs @@ -3,33 +3,34 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} module Db.User where -import Servant.Auth.JWT -import GHC.Generics (Generic) -import Data.Int -import Data.Functor.Identity (Identity) -import Data.Text (Text) import Data.Aeson (FromJSON, ToJSON) +import Data.Functor.Identity (Identity) +import Data.Int +import Data.Text (Text) +import GHC.Generics (Generic) import Password (HashedPassword) +import Servant.Auth.JWT import Core.User -import Rel8 (Column, Rel8able, Result, TableSchema (TableSchema, schema, name, columns), Name, Query, Expr, Insert (Insert, returning), returning, onConflict, rows, into, where_, (==.), lit, values, unsafeCastExpr, nextval, OnConflict (DoNothing), Returning (Projection, NumberOfRowsAffected), each, Update (Update, target, updateWhere, from, set, returning)) import Data.List (findIndex) +import Rel8 (Column, Expr, Insert (Insert, returning), Name, OnConflict (DoNothing), Query, Rel8able, Result, Returning (NumberOfRowsAffected, Projection), TableSchema (TableSchema, columns, name, schema), Update (Update, from, returning, set, target, updateWhere), each, into, lit, nextval, onConflict, returning, rows, unsafeCastExpr, values, where_, (==.)) data UserDB f = UserDB - { userDBId :: Column f UserId - , username :: Column f Text - , password :: Column f HashedPassword - , slug :: Column f Text - , externalTokens :: Column f [ExternalToken] - } deriving stock (Generic) + { userDBId :: Column f UserId + , username :: Column f Text + , password :: Column f HashedPassword + , slug :: Column f Text + , externalTokens :: Column f [ExternalToken] + } + deriving stock (Generic) deriving anyclass (Rel8able) deriving stock instance f ~ Result => Show (UserDB f) @@ -45,17 +46,19 @@ toUser :: User' -> User toUser (UserDB id name _ slug _) = User id name slug userSchema :: TableSchema (UserDB Name) -userSchema = TableSchema - { name = "users" - , schema = Nothing - , columns = UserDB - { userDBId = "id" - , username = "username" - , password = "password" - , slug = "slug" - , externalTokens = "external_tokens" - } - } +userSchema = + TableSchema + { name = "users" + , schema = Nothing + , columns = + UserDB + { userDBId = "id" + , username = "username" + , password = "password" + , slug = "slug" + , externalTokens = "external_tokens" + } + } selectAllUser :: Query (UserDB Expr) selectAllUser = each userSchema @@ -79,18 +82,22 @@ getUserBySlug s = do return u insertUser :: User' -> Insert [UserId] -insertUser (UserDB id name password slug _) = Insert - { into = userSchema - , rows = values [ UserDB { - userDBId = unsafeCastExpr $ nextval "users_id_seq", - username = lit name, - password = lit password, - slug = lit slug, - externalTokens = lit [] - } ] - , onConflict = DoNothing - , returning = Projection userDBId - } +insertUser (UserDB id name password slug _) = + Insert + { into = userSchema + , rows = + values + [ UserDB + { userDBId = unsafeCastExpr $ nextval "users_id_seq" + , username = lit name + , password = lit password + , slug = lit slug + , externalTokens = lit [] + } + ] + , onConflict = DoNothing + , returning = Projection userDBId + } getUserTokensById :: UserId -> Query (Expr [ExternalToken]) getUserTokensById uid = externalTokens <$> getUserById uid @@ -99,16 +106,18 @@ changeTokens :: [ExternalToken] -> ExternalToken -> [ExternalToken] changeTokens actual new = do case findIndex (\t -> service t == service new) actual of Nothing -> new : actual - Just idx -> let (x,_:ys) = splitAt idx actual - in x ++ new : ys + Just idx -> + let (x, _ : ys) = splitAt idx actual + in x ++ new : ys -updateUserTokens :: UserId -> [ExternalToken ] -> ExternalToken -> Update Int64 -updateUserTokens uid userTokens newToken = Update - { target = userSchema - , from = pure () - , updateWhere = \_ o -> userDBId o ==. lit uid - , set = setter - , returning = NumberOfRowsAffected - } - where - setter = \from row -> row { externalTokens = lit $ changeTokens userTokens newToken} \ No newline at end of file +updateUserTokens :: UserId -> [ExternalToken] -> ExternalToken -> Update Int64 +updateUserTokens uid userTokens newToken = + Update + { target = userSchema + , from = pure () + , updateWhere = \_ o -> userDBId o ==. lit uid + , set = setter + , returning = NumberOfRowsAffected + } + where + setter = \from row -> row{externalTokens = lit $ changeTokens userTokens newToken} diff --git a/api/src/Lib.hs b/api/src/Lib.hs index b0a5779..53cf3ba 100644 --- a/api/src/Lib.hs +++ b/api/src/Lib.hs @@ -1,27 +1,29 @@ -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingStrategies #-} module Lib where +import Api (NamedAPI, server) +import App +import Control.Monad.Trans.Reader (ReaderT, ask, runReaderT) +import qualified Hasql.Connection as Connection +import Hasql.Pool (acquire) import Network.Wai import Network.Wai.Handler.Warp import Servant -import Servant.Auth.Server (defaultJWTSettings, defaultCookieSettings, generateKey, JWTSettings, CookieSettings) -import qualified Hasql.Connection as Connection -import Api ( server, NamedAPI ) -import App -import Control.Monad.Trans.Reader (ReaderT, ask, runReaderT) -import Hasql.Pool (acquire) - +import Servant.Auth.Server (CookieSettings, JWTSettings, defaultCookieSettings, defaultJWTSettings, generateKey) api :: Proxy NamedAPI api = Proxy -app :: JWTSettings -> State -> Application -app jwtCfg state = +app :: JWTSettings -> State -> Application +app jwtCfg state = serveWithContext api cfg $ - hoistServerWithContext api (Proxy :: Proxy '[CookieSettings, JWTSettings]) - (`runReaderT` state) (Api.server cs jwtCfg) - where - cfg = defaultCookieSettings :. jwtCfg :. EmptyContext - cs = defaultCookieSettings + hoistServerWithContext + api + (Proxy :: Proxy '[CookieSettings, JWTSettings]) + (`runReaderT` state) + (Api.server cs jwtCfg) + where + cfg = defaultCookieSettings :. jwtCfg :. EmptyContext + cs = defaultCookieSettings diff --git a/api/src/OIDC.hs b/api/src/OIDC.hs index f802008..1f98649 100644 --- a/api/src/OIDC.hs +++ b/api/src/OIDC.hs @@ -1,11 +1,11 @@ -module OIDC -( module OIDC.Github -, getOauthTokens +module OIDC ( + module OIDC.Github, + getOauthTokens, ) where +import Core.User (ExternalToken, Service (Github)) import OIDC.Github -import Core.User (Service (Github), ExternalToken) getOauthTokens :: Service -> String -> IO (Maybe ExternalToken) getOauthTokens Github = getGithubTokens -getOauthTokens _ = \s -> return Nothing \ No newline at end of file +getOauthTokens _ = \s -> return Nothing diff --git a/api/src/OIDC/Discord.hs b/api/src/OIDC/Discord.hs index 5e4d31c..ced720e 100644 --- a/api/src/OIDC/Discord.hs +++ b/api/src/OIDC/Discord.hs @@ -1,48 +1,60 @@ {-# LANGUAGE OverloadedStrings #-} module OIDC.Discord where -import qualified Data.Text as T -import qualified Data.HashMap.Strict as HM -import qualified Data.ByteString.Char8 as B8 -import System.Environment.MrEnv ( envAsBool, envAsInt, envAsInteger, envAsString ) -import Network.HTTP.Simple (JSONException, parseRequest, setRequestMethod, addRequestHeader, setRequestQueryString, httpJSONEither, getResponseBody) -import Data.Aeson.Types (Object, Value (String)) -import Data.Text ( Text, pack ) +import qualified Data.ByteString.Char8 as B8 +import qualified Data.HashMap.Strict as HM +import qualified Data.Text as T + import App (AppM) import Core.User (ExternalToken (ExternalToken), Service (Github)) +import Data.Aeson.Types (Object, Value (String)) +import Data.Text (Text, pack) +import Network.HTTP.Simple (JSONException, addRequestHeader, getResponseBody, httpJSONEither, parseRequest, setRequestMethod, setRequestQueryString) +import System.Environment.MrEnv (envAsBool, envAsInt, envAsInteger, envAsString) import Utils (lookupObj) data DiscordOAuth2 = DiscordOAuth2 - { oauthClientId :: String - , oauthClientSecret :: String - , oauthOAuthorizeEndpoint :: String - , oauthAccessTokenEndpoint :: String - , oauthCallback :: String - } deriving (Show, Eq) - + { oauthClientId :: String + , oauthClientSecret :: String + , oauthOAuthorizeEndpoint :: String + , oauthAccessTokenEndpoint :: String + , oauthCallback :: String + } + deriving (Show, Eq) getDiscordConfig :: IO DiscordOAuth2 -getDiscordConfig = DiscordOAuth2 - <$> envAsString "DISCORD_CLIENT_ID" "" - <*> envAsString "DISCORD_SECRET" "" - <*> pure "https://github.com/login/oauth/authorize" - <*> pure "https://github.com/login/oauth/access_token" - <*> pure "http://localhost:8080/auth/github/token" - +getDiscordConfig = + DiscordOAuth2 + <$> envAsString "DISCORD_CLIENT_ID" "" + <*> envAsString "DISCORD_SECRET" "" + <*> pure "https://github.com/login/oauth/authorize" + <*> pure "https://github.com/login/oauth/access_token" + <*> pure "http://localhost:8080/auth/github/token" githubAuthEndpoint :: DiscordOAuth2 -> String -githubAuthEndpoint oa = concat [ oauthOAuthorizeEndpoint oa - , "?client_id=", oauthClientId oa - , "&response_type=", "code" - , "&redirect_uri=", oauthCallback oa] - +githubAuthEndpoint oa = + concat + [ oauthOAuthorizeEndpoint oa + , "?client_id=" + , oauthClientId oa + , "&response_type=" + , "code" + , "&redirect_uri=" + , oauthCallback oa + ] tokenEndpoint :: String -> DiscordOAuth2 -> String -tokenEndpoint code oa = concat [ oauthAccessTokenEndpoint oa - , "?client_id=", oauthClientId oa - , "&client_secret=", oauthClientSecret oa - , "&code=", code] +tokenEndpoint code oa = + concat + [ oauthAccessTokenEndpoint oa + , "?client_id=" + , oauthClientId oa + , "&client_secret=" + , oauthClientSecret oa + , "&code=" + , code + ] getGithubAuthEndpoint :: IO String getGithubAuthEndpoint = githubAuthEndpoint <$> getDiscordConfig @@ -50,19 +62,22 @@ getGithubAuthEndpoint = githubAuthEndpoint <$> getDiscordConfig -- Step 3. Exchange code for auth token getGithubTokens :: String -> IO (Maybe ExternalToken) getGithubTokens code = do - gh <- getDiscordConfig - let endpoint = tokenEndpoint code gh - request' <- parseRequest endpoint - let request = setRequestMethod "POST" - $ addRequestHeader "Accept" "application/json" - $ setRequestQueryString [ ("client_id", Just . B8.pack . oauthClientId $ gh) - , ("client_secret", Just . B8.pack . oauthClientSecret $ gh) - , ("code", Just . B8.pack $ code)] - $ request' - response <- httpJSONEither request - return $ case (getResponseBody response :: Either JSONException Object) of - Left _ -> Nothing - Right obj -> do - access <- lookupObj obj "access_token" - refresh <- lookupObj obj "refresh_token" - Just $ ExternalToken (pack access) (pack refresh) 0 Github \ No newline at end of file + gh <- getDiscordConfig + let endpoint = tokenEndpoint code gh + request' <- parseRequest endpoint + let request = + setRequestMethod "POST" $ + addRequestHeader "Accept" "application/json" $ + setRequestQueryString + [ ("client_id", Just . B8.pack . oauthClientId $ gh) + , ("client_secret", Just . B8.pack . oauthClientSecret $ gh) + , ("code", Just . B8.pack $ code) + ] + $ request' + response <- httpJSONEither request + return $ case (getResponseBody response :: Either JSONException Object) of + Left _ -> Nothing + Right obj -> do + access <- lookupObj obj "access_token" + refresh <- lookupObj obj "refresh_token" + Just $ ExternalToken (pack access) (pack refresh) 0 Github diff --git a/api/src/OIDC/Github.hs b/api/src/OIDC/Github.hs index 1544cc5..275229b 100644 --- a/api/src/OIDC/Github.hs +++ b/api/src/OIDC/Github.hs @@ -1,48 +1,59 @@ {-# LANGUAGE OverloadedStrings #-} module OIDC.Github where -import qualified Data.HashMap.Strict as HM -import qualified Data.ByteString.Char8 as B8 -import System.Environment.MrEnv ( envAsBool, envAsInt, envAsInteger, envAsString ) -import Network.HTTP.Simple (JSONException, parseRequest, setRequestMethod, addRequestHeader, setRequestQueryString, httpJSONEither, getResponseBody) -import Data.Aeson.Types (Object, Value (String)) -import Data.Text ( Text, pack ) +import qualified Data.ByteString.Char8 as B8 +import qualified Data.HashMap.Strict as HM + import App (AppM) import Core.User (ExternalToken (ExternalToken), Service (Github)) +import Data.Aeson.Types (Object, Value (String)) +import Data.Text (Text, pack) +import Network.HTTP.Simple (JSONException, addRequestHeader, getResponseBody, httpJSONEither, parseRequest, setRequestMethod, setRequestQueryString) +import System.Environment.MrEnv (envAsBool, envAsInt, envAsInteger, envAsString) import Utils (lookupObj) - data GithubOAuth2 = GithubOAuth2 - { oauthClientId :: String - , oauthClientSecret :: String - , oauthOAuthorizeEndpoint :: String - , oauthAccessTokenEndpoint :: String - , oauthCallback :: String - } deriving (Show, Eq) - + { oauthClientId :: String + , oauthClientSecret :: String + , oauthOAuthorizeEndpoint :: String + , oauthAccessTokenEndpoint :: String + , oauthCallback :: String + } + deriving (Show, Eq) getGithubConfig :: IO GithubOAuth2 -getGithubConfig = GithubOAuth2 - <$> envAsString "GITHUB_CLIENT_ID" "" - <*> envAsString "GITHUB_SECRET" "" - <*> pure "https://github.com/login/oauth/authorize" - <*> pure "https://github.com/login/oauth/access_token" - <*> pure "http://localhost:8080/auth/github/token" - +getGithubConfig = + GithubOAuth2 + <$> envAsString "GITHUB_CLIENT_ID" "" + <*> envAsString "GITHUB_SECRET" "" + <*> pure "https://github.com/login/oauth/authorize" + <*> pure "https://github.com/login/oauth/access_token" + <*> pure "http://localhost:8080/auth/github/token" githubAuthEndpoint :: GithubOAuth2 -> String -githubAuthEndpoint oa = concat [ oauthOAuthorizeEndpoint oa - , "?client_id=", oauthClientId oa - , "&response_type=", "code" - , "&redirect_uri=", oauthCallback oa] - +githubAuthEndpoint oa = + concat + [ oauthOAuthorizeEndpoint oa + , "?client_id=" + , oauthClientId oa + , "&response_type=" + , "code" + , "&redirect_uri=" + , oauthCallback oa + ] tokenEndpoint :: String -> GithubOAuth2 -> String -tokenEndpoint code oa = concat [ oauthAccessTokenEndpoint oa - , "?client_id=", oauthClientId oa - , "&client_secret=", oauthClientSecret oa - , "&code=", code] +tokenEndpoint code oa = + concat + [ oauthAccessTokenEndpoint oa + , "?client_id=" + , oauthClientId oa + , "&client_secret=" + , oauthClientSecret oa + , "&code=" + , code + ] getGithubAuthEndpoint :: IO String getGithubAuthEndpoint = githubAuthEndpoint <$> getGithubConfig @@ -50,19 +61,22 @@ getGithubAuthEndpoint = githubAuthEndpoint <$> getGithubConfig -- Step 3. Exchange code for auth token getGithubTokens :: String -> IO (Maybe ExternalToken) getGithubTokens code = do - gh <- getGithubConfig - let endpoint = tokenEndpoint code gh - request' <- parseRequest endpoint - let request = setRequestMethod "POST" - $ addRequestHeader "Accept" "application/json" - $ setRequestQueryString [ ("client_id", Just . B8.pack . oauthClientId $ gh) - , ("client_secret", Just . B8.pack . oauthClientSecret $ gh) - , ("code", Just . B8.pack $ code)] - $ request' - response <- httpJSONEither request - return $ case (getResponseBody response :: Either JSONException Object) of - Left _ -> Nothing - Right obj -> do - access <- lookupObj obj "access_token" - refresh <- lookupObj obj "refresh_token" - Just $ ExternalToken (pack access) (pack refresh) 0 Github \ No newline at end of file + gh <- getGithubConfig + let endpoint = tokenEndpoint code gh + request' <- parseRequest endpoint + let request = + setRequestMethod "POST" $ + addRequestHeader "Accept" "application/json" $ + setRequestQueryString + [ ("client_id", Just . B8.pack . oauthClientId $ gh) + , ("client_secret", Just . B8.pack . oauthClientSecret $ gh) + , ("code", Just . B8.pack $ code) + ] + $ request' + response <- httpJSONEither request + return $ case (getResponseBody response :: Either JSONException Object) of + Left _ -> Nothing + Right obj -> do + access <- lookupObj obj "access_token" + refresh <- lookupObj obj "refresh_token" + Just $ ExternalToken (pack access) (pack refresh) 0 Github diff --git a/api/src/OIDC/Google.hs b/api/src/OIDC/Google.hs index fd38839..5f4803e 100644 --- a/api/src/OIDC/Google.hs +++ b/api/src/OIDC/Google.hs @@ -1,54 +1,64 @@ {-# LANGUAGE OverloadedStrings #-} -module OIDC.Github where -import qualified Data.Text as T -import qualified Data.HashMap.Strict as HM -import qualified Data.ByteString.Char8 as B8 +module OIDC.Google where + +import qualified Data.ByteString.Char8 as B8 +import qualified Data.HashMap.Strict as HM +import qualified Data.Text as T -import System.Environment.MrEnv ( envAsBool, envAsInt, envAsInteger, envAsString ) -import Network.HTTP.Simple (JSONException, parseRequest, setRequestMethod, addRequestHeader, setRequestQueryString, httpJSONEither, getResponseBody) -import Data.Aeson.Types (Object, Value (String)) -import Data.Text ( Text, pack ) import App (AppM) import Core.User (ExternalToken (ExternalToken), Service (Github)) +import Data.Aeson.Types (Object, Value (String)) +import Data.Text (Text, pack) +import Network.HTTP.Simple (JSONException, addRequestHeader, getResponseBody, httpJSONEither, parseRequest, setRequestMethod, setRequestQueryString) +import System.Environment.MrEnv (envAsBool, envAsInt, envAsInteger, envAsString) import Utils (lookupObj) - data GoogleOAuth2 = GoogleOAuth2 - { oauthClientId :: String - , oauthClientSecret :: String - , oauthAccessTokenEndpoint :: String - } deriving (Show, Eq) - + { oauthClientId :: String + , oauthClientSecret :: String + , oauthAccessTokenEndpoint :: String + } + deriving (Show, Eq) getGoogleConfig :: IO GoogleOAuth2 -getGoogleConfig = GoogleOAuth2 - <$> envAsString "GOOGLE_CLIENT_ID" "" - <*> envAsString "GOOGLE_SECRET" "" - <*> pure "https://github.com/login/oauth/access_token" +getGoogleConfig = + GoogleOAuth2 + <$> envAsString "GOOGLE_CLIENT_ID" "" + <*> envAsString "GOOGLE_SECRET" "" + <*> pure "https://github.com/login/oauth/access_token" tokenEndpoint :: String -> GoogleOAuth2 -> String -tokenEndpoint code oa = concat [ oauthAccessTokenEndpoint oa - , "?client_id=", oauthClientId oa - , "&client_secret=", oauthClientSecret oa - , "&code=", code] +tokenEndpoint code oa = + concat + [ oauthAccessTokenEndpoint oa + , "?client_id=" + , oauthClientId oa + , "&client_secret=" + , oauthClientSecret oa + , "&code=" + , code + ] -- Step 3. Exchange code for auth token getGithubTokens :: String -> IO (Maybe ExternalToken) getGithubTokens code = do - gh <- getGoogleConfig - let endpoint = tokenEndpoint code gh - request' <- parseRequest endpoint - let request = setRequestMethod "POST" - $ addRequestHeader "Accept" "application/json" - $ setRequestQueryString [ ("client_id", Just . B8.pack . oauthClientId $ gh) - , ("client_secret", Just . B8.pack . oauthClientSecret $ gh) - , ("code", Just . B8.pack $ code)] - $ request' - response <- httpJSONEither request - return $ case (getResponseBody response :: Either JSONException Object) of - Left _ -> Nothing - Right obj -> do - access <- lookupObj obj "access_token" - refresh <- lookupObj obj "refresh_token" - Just $ ExternalToken (pack access) (pack refresh) 0 Github \ No newline at end of file + gh <- getGoogleConfig + let endpoint = tokenEndpoint code gh + request' <- parseRequest endpoint + let request = + setRequestMethod "POST" $ + addRequestHeader "Accept" "application/json" $ + setRequestQueryString + [ ("client_id", Just . B8.pack . oauthClientId $ gh) + , ("client_secret", Just . B8.pack . oauthClientSecret $ gh) + , ("code", Just . B8.pack $ code) + ] + $ request' + response <- httpJSONEither request + return $ case (getResponseBody response :: Either JSONException Object) of + Left _ -> Nothing + Right obj -> do + access <- lookupObj obj "access_token" + refresh <- lookupObj obj "refresh_token" + Just $ ExternalToken (pack access) (pack refresh) 0 Github diff --git a/api/src/OIDC/Spotify.hs b/api/src/OIDC/Spotify.hs index e842198..6e00309 100644 --- a/api/src/OIDC/Spotify.hs +++ b/api/src/OIDC/Spotify.hs @@ -1,54 +1,64 @@ {-# LANGUAGE OverloadedStrings #-} -module OIDC.Github where -import qualified Data.Text as T -import qualified Data.HashMap.Strict as HM -import qualified Data.ByteString.Char8 as B8 +module OIDC.Spotify where + +import qualified Data.ByteString.Char8 as B8 +import qualified Data.HashMap.Strict as HM +import qualified Data.Text as T -import System.Environment.MrEnv ( envAsBool, envAsInt, envAsInteger, envAsString ) -import Network.HTTP.Simple (JSONException, parseRequest, setRequestMethod, addRequestHeader, setRequestQueryString, httpJSONEither, getResponseBody) -import Data.Aeson.Types (Object, Value (String)) -import Data.Text ( Text, pack ) import App (AppM) import Core.User (ExternalToken (ExternalToken), Service (Github)) - +import Data.Aeson.Types (Object, Value (String)) +import Data.Text (Text, pack) +import Network.HTTP.Simple (JSONException, addRequestHeader, getResponseBody, httpJSONEither, parseRequest, setRequestMethod, setRequestQueryString) +import System.Environment.MrEnv (envAsBool, envAsInt, envAsInteger, envAsString) data GithubOAuth2 = GithubOAuth2 - { oauthClientId :: String - , oauthClientSecret :: String - , oauthOAuthorizeEndpoint :: String - , oauthAccessTokenEndpoint :: String - , oauthCallback :: String - } deriving (Show, Eq) - + { oauthClientId :: String + , oauthClientSecret :: String + , oauthOAuthorizeEndpoint :: String + , oauthAccessTokenEndpoint :: String + , oauthCallback :: String + } + deriving (Show, Eq) getGithubConfig :: IO GithubOAuth2 -getGithubConfig = GithubOAuth2 - <$> envAsString "GITHUB_CLIENT_ID" "" - <*> envAsString "GITHUB_SECRET" "" - <*> pure "https://github.com/login/oauth/authorize" - <*> pure "https://github.com/login/oauth/access_token" - <*> pure "http://localhost:8080/auth/github/token" - +getGithubConfig = + GithubOAuth2 + <$> envAsString "GITHUB_CLIENT_ID" "" + <*> envAsString "GITHUB_SECRET" "" + <*> pure "https://github.com/login/oauth/authorize" + <*> pure "https://github.com/login/oauth/access_token" + <*> pure "http://localhost:8080/auth/github/token" githubAuthEndpoint :: GithubOAuth2 -> String -githubAuthEndpoint oa = concat [ oauthOAuthorizeEndpoint oa - , "?client_id=", oauthClientId oa - , "&response_type=", "code" - , "&redirect_uri=", oauthCallback oa] - +githubAuthEndpoint oa = + concat + [ oauthOAuthorizeEndpoint oa + , "?client_id=" + , oauthClientId oa + , "&response_type=" + , "code" + , "&redirect_uri=" + , oauthCallback oa + ] tokenEndpoint :: String -> GithubOAuth2 -> String -tokenEndpoint code oa = concat [ oauthAccessTokenEndpoint oa - , "?client_id=", oauthClientId oa - , "&client_secret=", oauthClientSecret oa - , "&code=", code] - +tokenEndpoint code oa = + concat + [ oauthAccessTokenEndpoint oa + , "?client_id=" + , oauthClientId oa + , "&client_secret=" + , oauthClientSecret oa + , "&code=" + , code + ] lookupObj :: Object -> Text -> Maybe String lookupObj obj key = case HM.lookup key obj of - Just (String x) -> Just . T.unpack $ x - _ -> Nothing + Just (String x) -> Just . T.unpack $ x + _ -> Nothing getGithubAuthEndpoint :: IO String getGithubAuthEndpoint = githubAuthEndpoint <$> getGithubConfig @@ -56,19 +66,22 @@ getGithubAuthEndpoint = githubAuthEndpoint <$> getGithubConfig -- Step 3. Exchange code for auth token getGithubTokens :: String -> IO (Maybe ExternalToken) getGithubTokens code = do - gh <- getGithubConfig - let endpoint = tokenEndpoint code gh - request' <- parseRequest endpoint - let request = setRequestMethod "POST" - $ addRequestHeader "Accept" "application/json" - $ setRequestQueryString [ ("client_id", Just . B8.pack . oauthClientId $ gh) - , ("client_secret", Just . B8.pack . oauthClientSecret $ gh) - , ("code", Just . B8.pack $ code)] - $ request' - response <- httpJSONEither request - return $ case (getResponseBody response :: Either JSONException Object) of - Left _ -> Nothing - Right obj -> do - access <- lookupObj obj "access_token" - refresh <- lookupObj obj "refresh_token" - Just $ ExternalToken (pack access) (pack refresh) 0 Github \ No newline at end of file + gh <- getGithubConfig + let endpoint = tokenEndpoint code gh + request' <- parseRequest endpoint + let request = + setRequestMethod "POST" $ + addRequestHeader "Accept" "application/json" $ + setRequestQueryString + [ ("client_id", Just . B8.pack . oauthClientId $ gh) + , ("client_secret", Just . B8.pack . oauthClientSecret $ gh) + , ("code", Just . B8.pack $ code) + ] + $ request' + response <- httpJSONEither request + return $ case (getResponseBody response :: Either JSONException Object) of + Left _ -> Nothing + Right obj -> do + access <- lookupObj obj "access_token" + refresh <- lookupObj obj "refresh_token" + Just $ ExternalToken (pack access) (pack refresh) 0 Github diff --git a/api/src/OIDC/Twitter.hs b/api/src/OIDC/Twitter.hs index e842198..8c06192 100644 --- a/api/src/OIDC/Twitter.hs +++ b/api/src/OIDC/Twitter.hs @@ -1,54 +1,64 @@ {-# LANGUAGE OverloadedStrings #-} -module OIDC.Github where -import qualified Data.Text as T -import qualified Data.HashMap.Strict as HM -import qualified Data.ByteString.Char8 as B8 +module OIDC.Twitter where + +import qualified Data.ByteString.Char8 as B8 +import qualified Data.HashMap.Strict as HM +import qualified Data.Text as T -import System.Environment.MrEnv ( envAsBool, envAsInt, envAsInteger, envAsString ) -import Network.HTTP.Simple (JSONException, parseRequest, setRequestMethod, addRequestHeader, setRequestQueryString, httpJSONEither, getResponseBody) -import Data.Aeson.Types (Object, Value (String)) -import Data.Text ( Text, pack ) import App (AppM) import Core.User (ExternalToken (ExternalToken), Service (Github)) - +import Data.Aeson.Types (Object, Value (String)) +import Data.Text (Text, pack) +import Network.HTTP.Simple (JSONException, addRequestHeader, getResponseBody, httpJSONEither, parseRequest, setRequestMethod, setRequestQueryString) +import System.Environment.MrEnv (envAsBool, envAsInt, envAsInteger, envAsString) data GithubOAuth2 = GithubOAuth2 - { oauthClientId :: String - , oauthClientSecret :: String - , oauthOAuthorizeEndpoint :: String - , oauthAccessTokenEndpoint :: String - , oauthCallback :: String - } deriving (Show, Eq) - + { oauthClientId :: String + , oauthClientSecret :: String + , oauthOAuthorizeEndpoint :: String + , oauthAccessTokenEndpoint :: String + , oauthCallback :: String + } + deriving (Show, Eq) getGithubConfig :: IO GithubOAuth2 -getGithubConfig = GithubOAuth2 - <$> envAsString "GITHUB_CLIENT_ID" "" - <*> envAsString "GITHUB_SECRET" "" - <*> pure "https://github.com/login/oauth/authorize" - <*> pure "https://github.com/login/oauth/access_token" - <*> pure "http://localhost:8080/auth/github/token" - +getGithubConfig = + GithubOAuth2 + <$> envAsString "GITHUB_CLIENT_ID" "" + <*> envAsString "GITHUB_SECRET" "" + <*> pure "https://github.com/login/oauth/authorize" + <*> pure "https://github.com/login/oauth/access_token" + <*> pure "http://localhost:8080/auth/github/token" githubAuthEndpoint :: GithubOAuth2 -> String -githubAuthEndpoint oa = concat [ oauthOAuthorizeEndpoint oa - , "?client_id=", oauthClientId oa - , "&response_type=", "code" - , "&redirect_uri=", oauthCallback oa] - +githubAuthEndpoint oa = + concat + [ oauthOAuthorizeEndpoint oa + , "?client_id=" + , oauthClientId oa + , "&response_type=" + , "code" + , "&redirect_uri=" + , oauthCallback oa + ] tokenEndpoint :: String -> GithubOAuth2 -> String -tokenEndpoint code oa = concat [ oauthAccessTokenEndpoint oa - , "?client_id=", oauthClientId oa - , "&client_secret=", oauthClientSecret oa - , "&code=", code] - +tokenEndpoint code oa = + concat + [ oauthAccessTokenEndpoint oa + , "?client_id=" + , oauthClientId oa + , "&client_secret=" + , oauthClientSecret oa + , "&code=" + , code + ] lookupObj :: Object -> Text -> Maybe String lookupObj obj key = case HM.lookup key obj of - Just (String x) -> Just . T.unpack $ x - _ -> Nothing + Just (String x) -> Just . T.unpack $ x + _ -> Nothing getGithubAuthEndpoint :: IO String getGithubAuthEndpoint = githubAuthEndpoint <$> getGithubConfig @@ -56,19 +66,22 @@ getGithubAuthEndpoint = githubAuthEndpoint <$> getGithubConfig -- Step 3. Exchange code for auth token getGithubTokens :: String -> IO (Maybe ExternalToken) getGithubTokens code = do - gh <- getGithubConfig - let endpoint = tokenEndpoint code gh - request' <- parseRequest endpoint - let request = setRequestMethod "POST" - $ addRequestHeader "Accept" "application/json" - $ setRequestQueryString [ ("client_id", Just . B8.pack . oauthClientId $ gh) - , ("client_secret", Just . B8.pack . oauthClientSecret $ gh) - , ("code", Just . B8.pack $ code)] - $ request' - response <- httpJSONEither request - return $ case (getResponseBody response :: Either JSONException Object) of - Left _ -> Nothing - Right obj -> do - access <- lookupObj obj "access_token" - refresh <- lookupObj obj "refresh_token" - Just $ ExternalToken (pack access) (pack refresh) 0 Github \ No newline at end of file + gh <- getGithubConfig + let endpoint = tokenEndpoint code gh + request' <- parseRequest endpoint + let request = + setRequestMethod "POST" $ + addRequestHeader "Accept" "application/json" $ + setRequestQueryString + [ ("client_id", Just . B8.pack . oauthClientId $ gh) + , ("client_secret", Just . B8.pack . oauthClientSecret $ gh) + , ("code", Just . B8.pack $ code) + ] + $ request' + response <- httpJSONEither request + return $ case (getResponseBody response :: Either JSONException Object) of + Left _ -> Nothing + Right obj -> do + access <- lookupObj obj "access_token" + refresh <- lookupObj obj "refresh_token" + Just $ ExternalToken (pack access) (pack refresh) 0 Github diff --git a/api/src/Password.hs b/api/src/Password.hs index 511afdb..2c0fa47 100644 --- a/api/src/Password.hs +++ b/api/src/Password.hs @@ -1,25 +1,25 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE AllowAmbiguousTypes #-} module Password where -import Rel8 ( DBEq, DBType ) -import Data.Aeson ( FromJSON, ToJSON ) -import Data.Text ( Text, unpack ) +import Data.Aeson (FromJSON, ToJSON) +import Data.Text (Text, unpack) +import Rel8 (DBEq, DBType) -import Crypto.Random ( MonadRandom(getRandomBytes) ) -import Crypto.KDF.BCrypt -import qualified Data.ByteString.Char8 as B -import Data.ByteString (ByteString) -import Data.Text.Encoding (decodeUtf8, encodeUtf8) import Control.Monad.IO.Class (MonadIO, liftIO) +import Crypto.KDF.BCrypt +import Crypto.Random (MonadRandom (getRandomBytes)) import Data.ByteArray (Bytes, convert) +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as B +import Data.Text.Encoding (decodeUtf8, encodeUtf8) -newtype HashedPassword = HashedPassword { getHashedPasswd :: Text } +newtype HashedPassword = HashedPassword {getHashedPasswd :: Text} deriving newtype (Eq, Show, Read, DBEq, DBType, FromJSON, ToJSON) -newtype Password = Password { getPassword :: Text } +newtype Password = Password {getPassword :: Text} deriving newtype (Eq, Show, Read, FromJSON, ToJSON, DBEq, DBType) -- TODO Check if the password meets minimum security requirements @@ -40,8 +40,7 @@ newSalt = liftIO $ getRandomBytes 16 hashPassword' :: Password -> Bytes -> HashedPassword hashPassword' (Password password) salt = let hash = bcrypt 10 salt (textToBytes password) - in HashedPassword $ bytesToText hash - + in HashedPassword $ bytesToText hash hashPassword'' :: MonadIO m => Password -> m HashedPassword hashPassword'' password = hashPassword' password <$> newSalt @@ -54,4 +53,4 @@ hashPassword' (Password p) = hash = hashPassword 10 $ B.pack $ unpack p --} validatePassword' :: Password -> HashedPassword -> Bool -validatePassword' (Password p) (HashedPassword hp) = validatePassword (textToBytes p) (textToBytes hp) \ No newline at end of file +validatePassword' (Password p) (HashedPassword hp) = validatePassword (textToBytes p) (textToBytes hp) diff --git a/api/src/Repository.hs b/api/src/Repository.hs index 04ea849..a9e88dd 100644 --- a/api/src/Repository.hs +++ b/api/src/Repository.hs @@ -1,9 +1,9 @@ -module Repository -( module Repository.Pipeline -, module Repository.Reaction -, module Repository.User +module Repository ( + module Repository.Pipeline, + module Repository.Reaction, + module Repository.User, ) where import Repository.Pipeline import Repository.Reaction -import Repository.User \ No newline at end of file +import Repository.User diff --git a/api/src/Repository/Pipeline.hs b/api/src/Repository/Pipeline.hs index 35a69ef..719028f 100644 --- a/api/src/Repository/Pipeline.hs +++ b/api/src/Repository/Pipeline.hs @@ -1,17 +1,17 @@ {-# LANGUAGE BlockArguments #-} + module Repository.Pipeline where -import Db.Pipeline (PipelineId, Pipeline (Pipeline), getPipelineById, insertPipeline) + import App (AppM) import Data.Functor.Identity (Identity) +import Db.Pipeline (Pipeline (Pipeline), PipelineId, getPipelineById, insertPipeline) +import Rel8 (insert, limit, select) import Repository.Utils (runQuery) -import Rel8 (select, limit, insert) - getPipelineById' :: PipelineId -> AppM (Pipeline Identity) getPipelineById' pId = do res <- runQuery (select $ limit 1 $ getPipelineById pId) - return $ head res - + return $ head res createPipeline :: Pipeline Identity -> AppM [PipelineId] createPipeline pipeline = runQuery (insert $ insertPipeline pipeline) diff --git a/api/src/Repository/Reaction.hs b/api/src/Repository/Reaction.hs index b797d12..60ced6a 100644 --- a/api/src/Repository/Reaction.hs +++ b/api/src/Repository/Reaction.hs @@ -1,14 +1,16 @@ {-# LANGUAGE BlockArguments #-} + module Repository.Reaction where -import App (State(State, dbPool), AppM) -import Db.Reaction (Reaction(Reaction, reactionOrder), ReactionId (ReactionId), insertReaction, getReactionsByPipelineId) -import Data.Functor.Identity (Identity) + +import App (AppM, State (State, dbPool)) import Control.Monad.Trans.Reader (ask) -import Hasql.Transaction (statement, Transaction) -import Rel8 (insert, select, orderBy, asc) -import Hasql.Statement (Statement) -import Db.Pipeline (PipelineId(PipelineId)) import Data.Functor.Contravariant ((>$<)) +import Data.Functor.Identity (Identity) +import Db.Pipeline (PipelineId (PipelineId)) +import Db.Reaction (Reaction (Reaction, reactionOrder), ReactionId (ReactionId), getReactionsByPipelineId, insertReaction) +import Hasql.Statement (Statement) +import Hasql.Transaction (Transaction, statement) +import Rel8 (asc, insert, orderBy, select) import Repository.Utils (runQuery) createReaction :: Reaction Identity -> AppM [ReactionId] @@ -16,4 +18,3 @@ createReaction reaction = runQuery (insert $ insertReaction reaction) getReactionsByPipelineId' :: PipelineId -> AppM [Reaction Identity] getReactionsByPipelineId' pId = runQuery (select $ orderBy (reactionOrder >$< asc) $ getReactionsByPipelineId pId) - diff --git a/api/src/Repository/User.hs b/api/src/Repository/User.hs index 7221481..34c3e14 100644 --- a/api/src/Repository/User.hs +++ b/api/src/Repository/User.hs @@ -1,11 +1,11 @@ module Repository.User where -import Repository.Utils (runQuery) -import App (AppM) -import Db.User (User', insertUser, getUserByName, selectAllUser, getUserTokensById, updateUserTokens) -import Data.Text (Text) -import Core.User (UserId, ExternalToken) -import Rel8 (select, insert, update) +import App (AppM) +import Core.User (ExternalToken, UserId) +import Data.Text (Text) +import Db.User (User', getUserByName, getUserTokensById, insertUser, selectAllUser, updateUserTokens) +import Rel8 (insert, select, update) +import Repository.Utils (runQuery) users :: AppM [User'] users = runQuery (select selectAllUser) @@ -16,8 +16,8 @@ getUserByName' name = runQuery (select $ getUserByName name) createUser :: User' -> AppM [UserId] createUser user = runQuery (insert $ insertUser user) -updateTokens :: UserId -> ExternalToken -> AppM () +updateTokens :: UserId -> ExternalToken -> AppM () updateTokens uid new = do a <- runQuery (select $ getUserTokensById uid) runQuery (update $ updateUserTokens uid (head a) new) - return () \ No newline at end of file + return () diff --git a/api/src/Repository/Utils.hs b/api/src/Repository/Utils.hs index d9c8722..8a92b6d 100644 --- a/api/src/Repository/Utils.hs +++ b/api/src/Repository/Utils.hs @@ -1,14 +1,14 @@ module Repository.Utils where -import Hasql.Statement (Statement) -import App (AppM, State (dbPool, State)) -import qualified Hasql.Pool as Pool -import qualified Hasql.Transaction.Sessions as Hasql -import Hasql.Pool (Pool, UsageError (ConnectionError, SessionError)) -import Control.Monad.IO.Class (MonadIO (liftIO)) -import Hasql.Transaction (Transaction, statement) +import App (AppM, State (State, dbPool)) import Control.Exception (throwIO) +import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Monad.Trans.Reader (ask) +import Hasql.Pool (Pool, UsageError (ConnectionError, SessionError)) +import qualified Hasql.Pool as Pool +import Hasql.Statement (Statement) +import Hasql.Transaction (Transaction, statement) +import qualified Hasql.Transaction.Sessions as Hasql runTransactionWithPool :: MonadIO m => Pool -> Transaction b -> m b runTransactionWithPool pool transaction = do @@ -18,8 +18,7 @@ runTransactionWithPool pool transaction = do Left (ConnectionError e) -> error $ "Failed to connect to database, error: " ++ show e Left (SessionError e) -> error $ "session error" ++ show e - runQuery :: Statement () a -> AppM a runQuery t = do State{dbPool = p} <- ask - runTransactionWithPool p $ statement () t \ No newline at end of file + runTransactionWithPool p $ statement () t diff --git a/api/src/Utils.hs b/api/src/Utils.hs index d25cb3f..cf607e9 100644 --- a/api/src/Utils.hs +++ b/api/src/Utils.hs @@ -1,14 +1,14 @@ module Utils where + +import Data.Aeson.Types (Object, Value (String)) +import qualified Data.HashMap.Strict as HM import Data.Text (Text) import qualified Data.Text as T -import qualified Data.HashMap.Strict as HM -import Data.Aeson.Types (Object, Value (String)) mapInd :: (a -> Int -> b) -> [a] -> [b] -mapInd f l = zipWith f l [0..] - +mapInd f l = zipWith f l [0 ..] lookupObj :: Object -> Text -> Maybe String lookupObj obj key = case HM.lookup key obj of - Just (String x) -> Just . T.unpack $ x - _ -> Nothing \ No newline at end of file + Just (String x) -> Just . T.unpack $ x + _ -> Nothing diff --git a/api/test/Spec.hs b/api/test/Spec.hs index eb33885..f9caabf 100644 --- a/api/test/Spec.hs +++ b/api/test/Spec.hs @@ -1,20 +1,4 @@ --{-# LANGUAGE QuasiQuotes #-} --{-# LANGUAGE OverloadedStrings #-} --module Main (main) where -- --import Lib (app) --import Test.Hspec --import Test.Hspec.Wai --import Test.Hspec.Wai.JSON -- --main :: IO () --main = hspec spec -- --spec :: Spec --spec = with (return app) $ do -- describe "GET /users" $ do -- it "responds with 200" $ do -- get "/users" `shouldRespondWith` 200 -- it "responds with [User]" $ do -- let users = "[{\"userId\":1,\"userFirstName\":\"Isaac\",\"userLastName\":\"Newton\"},{\"userId\":2,\"userFirstName\":\"Albert\",\"userLastName\":\"Einstein\"}]" -- get "/users" `shouldRespondWith` users +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} + +module Main (main) where