246 lines
8.6 KiB
Haskell
246 lines
8.6 KiB
Haskell
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
|
{-# LANGUAGE DeriveGeneric #-}
|
|
{-# LANGUAGE FlexibleInstances #-}
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE TypeFamilies #-}
|
|
{-# LANGUAGE PackageImports #-}
|
|
|
|
{-# LANGUAGE NoImplicitPrelude #-}
|
|
|
|
module Server.Types where
|
|
|
|
import Relude
|
|
|
|
import Control.Monad.Except (throwError)
|
|
import Control.Monad.Logger (LoggingT)
|
|
import Data.Aeson (ToJSON(..), FromJSON(..))
|
|
import Data.ByteArray (ByteArray, ByteArrayAccess)
|
|
import Data.Morpheus.App.Internal.Resolving (Resolver, LiftOperation)
|
|
import Data.Morpheus.Server.Types (SCALAR)
|
|
import Data.Morpheus.Types (GQLType, DecodeScalar(..), KIND, EncodeScalar(..),
|
|
ScalarValue(..), MonadError, GQLError)
|
|
import Data.Morpheus.Types.GQLScalar (scalarToJSON, scalarFromJSON)
|
|
import Data.Time (UTCTime, getCurrentTime, NominalDiffTime, addUTCTime, Day)
|
|
import Data.Time.Format.ISO8601 (iso8601Show, iso8601ParseM)
|
|
import Database.Persist.Class (PersistField(..))
|
|
import Database.Persist.PersistValue (PersistValue(..))
|
|
import Database.Persist.Sql (PersistFieldSql(..), SqlBackend)
|
|
import Network.Mail.Mime (Mail, Address(..))
|
|
import Text.Email.Validate (EmailAddress, toByteString, validate, emailAddress)
|
|
import qualified Data.ByteString.Base64 as B64 (encode, decode)
|
|
import "cryptonite" Crypto.Random (MonadRandom(..))
|
|
|
|
base64Encode :: ByteString -> Base64
|
|
base64Encode = Base64 . decodeUtf8 . B64.encode
|
|
|
|
base64Decode :: Base64 -> Maybe ByteString
|
|
base64Decode (Base64 x) = either (const Nothing) Just $ B64.decode $ encodeUtf8 x
|
|
|
|
toEmail :: Text -> Maybe Email
|
|
toEmail = fmap Email . emailAddress . encodeUtf8
|
|
|
|
renderEmail :: Email -> Text
|
|
renderEmail (Email x) = decodeUtf8 $ toByteString x
|
|
|
|
renderTime :: Time -> Text
|
|
renderTime (Time x) = toText $ iso8601Show x
|
|
|
|
toTime :: Text -> Maybe Time
|
|
toTime = fmap Time . iso8601ParseM . toString
|
|
|
|
toDate :: Text -> Maybe Date
|
|
toDate = fmap Date . iso8601ParseM . toString
|
|
|
|
renderDate :: Date -> Text
|
|
renderDate (Date x) = toText $ iso8601Show x
|
|
|
|
addTime :: NominalDiffTime -> Time -> Time
|
|
addTime diff (Time time) = Time $ addUTCTime diff time
|
|
|
|
forward :: Monad m => [a] -> m [Maybe a]
|
|
forward = pure . map Just
|
|
|
|
requirePermission :: (MonadPermissions m, MonadError GQLError m) => Scope -> Permission -> m ()
|
|
requirePermission scope permission = unlessM (hasPermission scope permission) $
|
|
throwError $ "Insufficient permissions, " <> show permission <> " for "
|
|
<> show scope <> " required."
|
|
|
|
data Scope = OwnProfile
|
|
| OwnTokens
|
|
| Profile UserID
|
|
| Tokens UserID
|
|
| Members
|
|
| Applications
|
|
deriving (Show, Eq, Ord, Read)
|
|
|
|
data Permission = None
|
|
| ReadOnly
|
|
| ReadWrite
|
|
deriving (Show, Eq, Ord, Read)
|
|
|
|
data MemberData = MemberData
|
|
{ name :: Text
|
|
, nickname :: Maybe Text
|
|
, birthdate :: Date
|
|
, homeplace :: Text
|
|
, application :: Text
|
|
} deriving (Show, Eq, Generic)
|
|
|
|
instance FromJSON MemberData
|
|
instance ToJSON MemberData
|
|
|
|
newtype UserID = UserID Int64 deriving (Eq, Show, Generic, Ord, Read)
|
|
|
|
instance DecodeScalar UserID where
|
|
decodeScalar (String s) = first (const $ "invalid UserID: \"" <> s <> "\"") $
|
|
UserID <$> readEither (toString s)
|
|
decodeScalar _ = Left "Invalid type for UserID, should be string"
|
|
|
|
instance EncodeScalar UserID where
|
|
encodeScalar (UserID x) = String $ show x
|
|
|
|
instance GQLType UserID where type KIND UserID = SCALAR
|
|
instance ToJSON UserID where toJSON = scalarToJSON
|
|
instance FromJSON UserID where parseJSON = scalarFromJSON <=< parseJSON
|
|
|
|
newtype KeyID = KeyID Int64 deriving (Eq, Show, Generic)
|
|
|
|
instance DecodeScalar KeyID where
|
|
decodeScalar (String s) = first (const $ "invalid KeyID: \"" <> s <> "\"") $
|
|
KeyID <$> readEither (toString s)
|
|
decodeScalar _ = Left "Invalid type for KeyID, should be string"
|
|
|
|
instance EncodeScalar KeyID where
|
|
encodeScalar (KeyID s) = String $ show s
|
|
|
|
instance GQLType KeyID where type KIND KeyID = SCALAR
|
|
instance ToJSON KeyID where toJSON = scalarToJSON
|
|
instance FromJSON KeyID where parseJSON = scalarFromJSON <=< parseJSON
|
|
|
|
newtype TokenID = TokenID Int64 deriving (Eq, Show, Generic)
|
|
|
|
instance DecodeScalar TokenID where
|
|
decodeScalar (String s) = first (const $ "invalid TokenID: \"" <> s <> "\"") $
|
|
TokenID <$> readEither (toString s)
|
|
decodeScalar _ = Left "Invalid type for TokenID, should be string"
|
|
|
|
instance EncodeScalar TokenID where
|
|
encodeScalar (TokenID s) = String $ show s
|
|
|
|
instance GQLType TokenID where type KIND TokenID = SCALAR
|
|
instance ToJSON TokenID where toJSON = scalarToJSON
|
|
instance FromJSON TokenID where parseJSON = scalarFromJSON <=< parseJSON
|
|
|
|
newtype Base64 = Base64 Text
|
|
deriving (Eq, Show, ToJSON, FromJSON, Generic, DecodeScalar, EncodeScalar)
|
|
|
|
instance GQLType Base64 where type KIND Base64 = SCALAR
|
|
|
|
newtype Email = Email EmailAddress deriving (Eq, Show)
|
|
|
|
instance DecodeScalar Email where
|
|
decodeScalar (String s) = maybe (Left $ "Couldn't parse \"" <> s <> "\" as an email address") (Right . Email) $ emailAddress $ encodeUtf8 s
|
|
decodeScalar _ = Left "Invalid type for Email, should be string"
|
|
|
|
instance EncodeScalar Email where
|
|
encodeScalar = String . renderEmail
|
|
|
|
instance GQLType Email where type KIND Email = SCALAR
|
|
instance ToJSON Email where toJSON = scalarToJSON
|
|
instance FromJSON Email where parseJSON = scalarFromJSON <=< parseJSON
|
|
|
|
instance PersistField Email where
|
|
toPersistValue = PersistText . renderEmail
|
|
fromPersistValue (PersistText email) =
|
|
second Email $ first toText $ validate $ encodeUtf8 email
|
|
fromPersistValue x = Left $ "Wrong type for Email: " <> show x
|
|
|
|
newtype Time = Time UTCTime deriving (Eq, Show, PersistField, PersistFieldSql)
|
|
|
|
instance DecodeScalar Time where
|
|
decodeScalar (String s) = maybe
|
|
(Left $ "Couldn't parse \"" <> s <> "\" as an ISO8601 timestamp")
|
|
(Right) $ toTime s
|
|
decodeScalar _ = Left "Invalid type for Time, should be string"
|
|
|
|
instance EncodeScalar Time where
|
|
encodeScalar = String . renderTime
|
|
|
|
instance GQLType Time where type KIND Time = SCALAR
|
|
instance ToJSON Time where toJSON = scalarToJSON
|
|
instance FromJSON Time where parseJSON = scalarFromJSON <=< parseJSON
|
|
|
|
newtype Date = Date Day deriving (Eq, Show, PersistField, Generic)
|
|
|
|
instance DecodeScalar Date where
|
|
decodeScalar (String s) = maybe
|
|
(Left $ "Couldn't parse \"" <> s <> "\" as an ISO8601 date")
|
|
(Right) $ toDate s
|
|
decodeScalar _ = Left "Invalid type for Date, should be string"
|
|
|
|
instance EncodeScalar Date where
|
|
encodeScalar = String . renderDate
|
|
|
|
instance GQLType Date where type KIND Date = SCALAR
|
|
instance ToJSON Date where toJSON = scalarToJSON
|
|
instance FromJSON Date where parseJSON = scalarFromJSON <=< parseJSON
|
|
|
|
newtype PasswordHash = PasswordHash ByteString
|
|
deriving (Eq, Show, Ord, Semigroup, Monoid, ByteArrayAccess, ByteArray,
|
|
PersistField, PersistFieldSql)
|
|
|
|
class Monad m => MonadTime m where
|
|
currentTime :: m Time
|
|
|
|
instance MonadTime IO where
|
|
currentTime = Time <$> getCurrentTime
|
|
|
|
class Monad m => MonadDB m where
|
|
runQuery :: ReaderT SqlBackend (LoggingT IO) a -> m a
|
|
-- TODO refactor so that it is possible to define a IO-less db, for safety and testability.
|
|
-- Is there a way to do this that doesn't require moving all db calls to the class?
|
|
-- Probably not :(
|
|
|
|
class Monad m => MonadEmail m where
|
|
sendEmail :: Mail -> m ()
|
|
fromAddress :: m Address
|
|
|
|
class Monad m => MonadRequest m where
|
|
currentUser :: m (Maybe UserID)
|
|
|
|
class Monad m => MonadPermissions m where
|
|
hasPermission :: Scope -> Permission -> m Bool
|
|
currentPermissions :: m Text
|
|
defaultPermissions :: m Text
|
|
toPermissions :: Text -> m (Maybe Text)
|
|
|
|
instance (MonadDB m, LiftOperation o) => MonadDB (Resolver o () m) where
|
|
runQuery = lift . runQuery
|
|
|
|
instance (MonadRequest m, LiftOperation o) => MonadRequest (Resolver o () m) where
|
|
currentUser = lift currentUser
|
|
|
|
instance (MonadPermissions m, LiftOperation o) => MonadPermissions (Resolver o () m) where
|
|
hasPermission scope permission = lift $ hasPermission scope permission
|
|
defaultPermissions = lift defaultPermissions
|
|
currentPermissions = lift currentPermissions
|
|
toPermissions = lift . toPermissions
|
|
|
|
instance (MonadEmail m, LiftOperation o) => MonadEmail (Resolver o () m) where
|
|
sendEmail = lift . sendEmail
|
|
fromAddress = lift fromAddress
|
|
|
|
instance (MonadRandom m, LiftOperation o) => MonadRandom (Resolver o () m) where
|
|
getRandomBytes = lift . getRandomBytes
|
|
|
|
instance (MonadTime m, LiftOperation o) => MonadTime (Resolver o () m) where
|
|
currentTime = lift currentTime
|
|
|
|
data Unit = Unit | Unit2 deriving (Eq, Generic, Show)
|
|
|
|
instance GQLType Unit
|
|
instance ToJSON Unit
|
|
instance FromJSON Unit
|