datarekisteri/Server/Types.hs

{-# 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 qualified Data.Text as T
import Data.Char (isSpace)
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 "base64" Data.ByteString.Base64 as B64 (encodeBase64, decodeBase64)
import "cryptonite" Crypto.Random (MonadRandom(..))

base64Encode :: ByteString -> Base64
base64Encode = Base64 . B64.encodeBase64

base64Decode :: Base64 -> Maybe ByteString
base64Decode (Base64 x) = either (const Nothing) Just $ B64.decodeBase64 $ 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
    , phoneNumber :: PhoneNumber
    } deriving (Show, Eq, Generic)

instance FromJSON MemberData
instance ToJSON MemberData

newtype PhoneNumber = PhoneNumber Text deriving (Show, Generic)

renderPhoneNumber :: PhoneNumber -> Text
renderPhoneNumber (PhoneNumber txt) = txt

toPhoneNumber :: Text -> Maybe PhoneNumber
toPhoneNumber txt = do
    guard $ not $ T.null txt
    guard $ T.all (`elem` ("+ 0123456789" :: [Char])) txt
    pure $ PhoneNumber txt

instance Eq PhoneNumber where
    a == b = normalize a == normalize b
        where normalize (PhoneNumber txt) = case T.uncons txt of
                                            Just ('0', rest) -> "+358" <> T.filter (not . isSpace) rest
                                            Just x -> T.filter (not . isSpace) (uncurry T.cons x)
                                            Nothing -> error "PhoneNumber must not be empty"

instance DecodeScalar PhoneNumber where
    decodeScalar (String s) =
        maybe (Left $ "Couldn't parse \"" <> s <> "\" as a PhoneNumber") Right $ toPhoneNumber s
    decodeScalar _ = Left "Invalid type for PhoneNumber, should be string"

instance EncodeScalar PhoneNumber where
    encodeScalar = String . renderPhoneNumber

instance GQLType PhoneNumber where type KIND PhoneNumber = SCALAR
instance ToJSON PhoneNumber where toJSON = scalarToJSON
instance FromJSON PhoneNumber where parseJSON = scalarFromJSON <=< parseJSON

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