Last active
August 11, 2016 08:22
-
-
Save tlaitinen/34c965006a3f7521a980b20a13d8a6ed to your computer and use it in GitHub Desktop.
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
{-# 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 App e | |
canPost :: UserId -> i -> SqlPersistT App Bool | |
canPut :: UserId -> Key e -> i -> SqlPersistT App Bool | |
canDel :: UserId -> Key e -> SqlPersistT App 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 App (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 App () | |
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 App () | |
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 => UserId -> ServerT (APIFor e q i o) App | |
serverFor authId = getMany authId | |
:<|> post authId | |
:<|> (\eId -> | |
(getOne authId eId) | |
:<|> (put authId eId) | |
:<|> (del authId eId)) | |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment