datarekisteri/Server/Types.hs

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