Database.hs

{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE FlexibleContexts #-}
module Api.Database where

import Servant
import Models
import qualified Database.Persist.Sql as P
import Database.Esqueleto
import Database.Esqueleto.Internal.Sql (SqlSelect)
import Database.Esqueleto.Internal.Language (From)
import Data.Int 
import Config
import Data.Aeson (ToJSON(..))

type APIFor e q i o = QueryParam "query" q :> Get '[JSON] [o]
  :<|> ReqBody '[JSON] i :> Post '[JSON] (Key e) 
  :<|> Capture "id" (Key e) :>
         ( Get '[JSON] o
              :<|> ReqBody '[JSON] i :> Put '[JSON] () 
              :<|> Delete '[JSON] ())

defaultLimit :: Int64
defaultLimit = 100

class (PersistEntity e, PersistEntityBackend e ~ SqlBackend)
    => ServerFor e q i o 
        | e -> q, e -> i, e -> o, q -> e, i -> e, o -> e where

    fromIn :: UserId -> i -> SqlPersistT IO e

    canPost :: UserId -> i -> SqlPersistT IO Bool
    canPut :: UserId -> Key e -> i -> SqlPersistT IO Bool
    canDel :: UserId -> Key e -> SqlPersistT IO Bool

    doSelect :: UserId -> Maybe (Key e) -> Maybe q -> App [o]

    getMany  :: UserId -> Maybe q -> App [o]
    getMany authId mq = doSelect authId Nothing mq

    doPost :: UserId -> e -> SqlPersistT IO (Key e)
    doPost _ e = insert e

    post :: UserId -> i -> App (Key e)
    post authId i = do
        meid <- runDB $ do
            ok <- canPost authId i
            if ok
                then do 
                    e <- fromIn authId i
                    fmap Just $ doPost authId e
                else return Nothing
        case meid of
            Just eId -> return eId
            Nothing -> throwError err403

    getOne  :: UserId -> Key e -> App o
    getOne authId k = do
        xs <- doSelect authId (Just k) Nothing
        case xs of
            [o] -> return o
            _ -> throwError err404
        
    doPut :: UserId -> Key e -> e -> SqlPersistT IO ()
    doPut _ k e = replace k e

    put :: UserId -> Key e -> i -> App ()
    put authId k i = do
        success <- runDB $ do
            ok <- canPut authId k i
            if ok
                then do
                    e <- fromIn authId i
                    doPut authId k e
                    return True
                else return False
        if success then return () else throwError err403            
  
    doDel :: UserId -> Key e -> SqlPersistT IO ()
    doDel _ k = P.delete k
      
    del :: UserId -> Key e -> App ()    
    del authId k = do
        success <- runDB $ do
            ok <- canDel authId k
            if ok
                then do
                    doDel authId k
                    return True
                else return False
        if success then return () else throwError err403
        

serverFor :: forall e q i o. ServerFor e q i o => App UserId -> ServerT (APIFor e q i o) App
serverFor getAuthId = (\q -> do
        authId <- getAuthId 
        getMany authId q)
    :<|> (\e -> do
        authId <- getAuthId
        post authId e)
    :<|> (\eId -> 
        (do
            authId <- getAuthId
            getOne authId eId)
        :<|> (\e -> do
            authId <- getAuthId
            put authId eId e)
        :<|> (do
            authId <- getAuthId
            del authId eId))