zoriya/Aeris
1
0
Fork 0
mirror of https://github.com/zoriya/Aeris.git synced 2025-12-06 06:36:12 +00:00
Code Issues Packages Projects Releases Wiki Activity

format: formatted files with fourmolu

Browse Source
This commit is contained in:
GitBluub
2022-02-18 15:01:13 +01:00
parent 7beda9788f
commit 244b488d45
31 changed files with 873 additions and 760 deletions
Download Patch File Download Diff File Expand all files Collapse all files

1
api/Setup.hs
View File

@@ -1,2 +1,3 @@
import Distribution.Simple
main = defaultMain

19
api/app/Main.hs
View File

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

39
api/src/Api.hs
View File

@@ -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
nt s x = runReaderT x s

58
api/src/Api/About.hs
View File

@@ -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)
Right services -> return $ About (ClientAbout $ show host) (ServerAbout now services)

159
api/src/Api/Auth.hs
View File

@@ -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
}
authHandler cs jwts =
AuthAPI
{ protectedApi = protected
, unprotectedApi = unprotected cs jwts
, oauthApi = oauth
}

23
api/src/Api/OIDC.hs
View File

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

95
api/src/Api/Pipeline.hs
View File

@@ -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
}
pipelineHandler =
PipelineAPI
{ get = getPipelineHandler
, post = postPipelineHandler
, put = putPipelineHandler
, del = delPipelineHandler
}

10
api/src/App.hs
View File

@@ -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
nt s x = runReaderT x s

42
api/src/Config.hs
View File

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

23
api/src/Core/OIDC.hs
View File

@@ -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"
}
oidcGoogleConf =
OIDCConf
{ redirectUri = "http://localhost:8080/auth/login/google"
, clientId = "914790981890-qjn5qjq5qjqjqjqjqjqjqjqjqjqjqjq.apps.googleusercontent.com"
, clientPassword = "914790981890-qjn5qjq5qjqjqjqjqjqjqjqjqjqjqjqjq"
}

38
api/src/Core/Pipeline.hs
View File

@@ -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
deriving (DBType) via JSONBEncoded PipelineParams

34
api/src/Core/Reaction.hs
View File

@@ -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
deriving (DBType) via JSONBEncoded ReactionParams

80
api/src/Core/User.hs
View File

@@ -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)
$(deriveJSON defaultOptions ''User)

93
api/src/Db/Pipeline.hs
View File

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

108
api/src/Db/Reaction.hs
View File

@@ -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
r <- each reactionSchema
where_ $ reactionPipelineId r ==. lit pId
return r

107
api/src/Db/User.hs
View File

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

32
api/src/Lib.hs
View File

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

10
api/src/OIDC.hs
View File

@@ -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
getOauthTokens _ = \s -> return Nothing

107
api/src/OIDC/Discord.hs
View File

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

106
api/src/OIDC/Github.hs
View File

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

86
api/src/OIDC/Google.hs
View File

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

115
api/src/OIDC/Spotify.hs
View File

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

115
api/src/OIDC/Twitter.hs
View File

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

27
api/src/Password.hs
View File

@@ -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)
validatePassword' (Password p) (HashedPassword hp) = validatePassword (textToBytes p) (textToBytes hp)

10
api/src/Repository.hs
View File

@@ -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
import Repository.User

10
api/src/Repository/Pipeline.hs
View File

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

17
api/src/Repository/Reaction.hs
View File

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

16
api/src/Repository/User.hs
View File

@@ -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 ()
return ()

17
api/src/Repository/Utils.hs
View File

@@ -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
runTransactionWithPool p $ statement () t

12
api/src/Utils.hs
View File

@@ -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
Just (String x) -> Just . T.unpack $ x
_ -> Nothing

24
api/test/Spec.hs
View File

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