generic.hs

{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RankNTypes #-}

module Main where

import Rest
import Rest.Api
import qualified Rest.Gen as Gen
import qualified Rest.Gen.Config as Gen
import qualified Rest.Resource as R
import Rest.Driver.Snap
import Snap.Core (Snap)
import Snap.Http.Server

import Database.PostgreSQL.Simple
import Database.PostgreSQL.ORM
import Database.PostgreSQL.ORM.Model
import Database.PostgreSQL.ORM.CreateTable
import Data.Text
import GHC.Generics

import Control.Monad.Reader
import Control.Applicative
import Control.Monad.Error

import Data.JSON.Schema
import Data.Aeson hiding (Number, Object)
import Data.Typeable
import qualified Data.ByteString.Char8 as B

import qualified Rest.Client.Internal as C
import qualified Rest.Types.Container
import qualified Rest.Types.Error
import qualified Rest.StringMap.HashMap.Strict

data Post = Post
  { postId :: DBKey
  , postTitle :: Text
  , postBody :: Text
  } deriving (Generic, Typeable, Show)
instance Model Post
instance JSONSchema Post where
  schema = gSchema
instance JSONSchema DBKey where
  schema _ = Choice [ Object [Field {key = "dBKey", required = True, content = Number unbounded}]
                    , Object [Field {key = "nullKey", required = True, content = Object []}]]
instance ToJSON Post where
instance FromJSON Post where

data ListId a = All

type GenericResource m tr x = Resource (ReaderT Connection m) (ReaderT (GDBRef tr x) (ReaderT Connection m)) (GDBRef tr x) (ListId x) Void

resource :: forall m x tr. (MonadIO m, Applicative m, Model x, JSONSchema x, ToJSON x, FromJSON x, Typeable x) => GenericResource m tr x
resource = mkResourceReader
  { R.name   = B.unpack . modelTable $ (modelInfo :: ModelInfo x)
  , R.schema = withListing All $ named [("id", singleBy (DBRef . read))]
  , R.list   = list
  , R.get    = Just get
  , R.update = Just update
  , R.remove = Just remove
  , R.create = Just (create (Proxy :: Proxy x))
  }

list :: forall m x. (MonadIO m, Model x, JSONSchema x, ToJSON x, Typeable x) => ListId x -> ListHandler (ReaderT Connection m)
list All = mkListing (jsonO . someO) $ \range -> do
  conn <- ask
  liftIO $ (findAll conn :: IO [x])

get :: (MonadIO m, Model x, JSONSchema x, ToJSON x, Typeable x) => Handler (ReaderT (GDBRef tr x) (ReaderT Connection m))
get = mkIdHandler (jsonE . jsonO . someO) $ \_ pk -> do
  conn <- lift . lift $ ask
  x <- liftIO $ findRow conn pk
  maybe (throwError NotFound) return x

update :: forall m x tr. (MonadIO m, Model x, JSONSchema x, FromJSON x, Typeable x) => Handler (ReaderT (GDBRef tr x) (ReaderT Connection m))
update = mkInputHandler (jsonE . jsonI . someI) $ \x -> do
  conn <- lift . lift $ ask
  res <- liftIO $ trySave conn (x :: x)
  either (throwError . InputError . UnsupportedFormat . show) (const $ return ()) res

remove :: (MonadIO m, Model x, JSONSchema x, ToJSON x, Typeable x) => Handler (ReaderT (GDBRef tr x) (ReaderT Connection m))
remove = mkIdHandler id $ \_ pk -> do
  conn <- lift . lift $ ask
  liftIO $ destroyByRef conn pk

create :: forall m x. (MonadIO m, Model x, JSONSchema x, FromJSON x, Typeable x) => Proxy x -> Handler (ReaderT Connection m)
create _ = mkInputHandler (jsonI . someI) $ \x -> do
  conn <- ask
  res <- liftIO $ trySave conn (x :: x)
  either (throwError . InputError . UnsupportedFormat . show) (const $ return ()) res

testRouter :: forall m . (Applicative m, MonadIO m) => Router (ReaderT Connection m) (ReaderT Connection m)
testRouter = root -/ post
  where
    post = route (resource :: GenericResource m tr Post)

testApi :: Api (ReaderT Connection Snap)
testApi = [(mkVersion 1 0 0, Some1 testRouter)]

runStack :: Connection -> ReaderT Connection Snap a -> Snap a
runStack conn m = runReaderT m conn

testSnap :: Connection -> Snap ()
testSnap conn = apiToHandler' (runStack conn) testApi

main :: IO ()
main = do
  config <- Gen.configFromArgs "rest-example-gen"
  Gen.generate config "RestExample" testApi [] [] []
  conn <- connectPostgreSQL ""
--  modelCreate conn (undefined :: Post)
  let snap = testSnap conn
  quickHttpServe snap


type Identifier = String
 
readId :: Identifier -> [String]
readId x = ["id", C.showUrl x]
 
listC ::
       C.ApiStateC m =>
       [(String, String)] ->
         m (C.ApiResponse () (Rest.Types.Container.List (Main.Post)))
listC pList
  = let rHeaders
          = [(C.hAccept, "text/json"), (C.hContentType, "text/plain")]
        request = C.makeReq "GET" "v1.0.0" [["post"]] pList rHeaders ""
      in C.doRequest C.fromJSON C.fromJSON request
 
byId :: C.ApiStateC m => String -> m (C.ApiResponse () Main.Post)
byId string
  = let rHeaders
          = [(C.hAccept, "text/json"), (C.hContentType, "text/plain")]
        request
          = C.makeReq "GET" "v1.0.0" [["post"], ["id"], [C.showUrl string]] []
              rHeaders
              ""
      in C.doRequest C.fromJSON C.fromJSON request
 
saveById ::
           C.ApiStateC m => String -> Main.Post -> m (C.ApiResponse () ())
saveById string input
  = let rHeaders
          = [(C.hAccept, "text/json"), (C.hContentType, "text/json")]
        request
          = C.makeReq "PUT" "v1.0.0" [["post"], ["id"], [C.showUrl string]] []
              rHeaders
              (C.toJSON input)
      in C.doRequest C.fromXML (const ()) request
 
saveManyById ::
               C.ApiStateC m =>
               Rest.StringMap.HashMap.Strict.StringHashMap ([(Char)]) (Main.Post)
                 ->
                 m (C.ApiResponse (Rest.Types.Error.Reason (()))
                      (Rest.StringMap.HashMap.Strict.StringHashMap ([(Char)])
                         (Rest.Types.Error.Status (Rest.Types.Error.Reason (())) (()))))
saveManyById input
  = let rHeaders
          = [(C.hAccept, "text/json"), (C.hContentType, "text/json")]
        request
          = C.makeReq "PUT" "v1.0.0" [["post"], ["id"]] [] rHeaders
              (C.toJSON input)
      in C.doRequest C.fromJSON C.fromJSON request
 
removeManyId ::
               C.ApiStateC m =>
               Rest.StringMap.HashMap.Strict.StringHashMap ([(Char)]) (()) ->
                 m (C.ApiResponse (Rest.Types.Error.Reason (()))
                      (Rest.StringMap.HashMap.Strict.StringHashMap ([(Char)])
                         (Rest.Types.Error.Status (Rest.Types.Error.Reason (())) (()))))
removeManyId input
  = let rHeaders
          = [(C.hAccept, "text/json"), (C.hContentType, "text/json")]
        request
          = C.makeReq "DELETE" "v1.0.0" [["post"], ["id"]] [] rHeaders
              (C.toJSON input)
      in C.doRequest C.fromJSON C.fromJSON request
 
createC :: C.ApiStateC m => Main.Post -> m (C.ApiResponse () ())
createC input
  = let rHeaders
          = [(C.hAccept, "text/json"), (C.hContentType, "text/json")]
        request
          = C.makeReq "POST" "v1.0.0" [["post"]] [] rHeaders (C.toJSON input)
      in C.doRequest C.fromXML (const ()) request
 
removeC :: C.ApiStateC m => Identifier -> m (C.ApiResponse () ())
removeC post
  = let rHeaders
          = [(C.hAccept, "text/json"), (C.hContentType, "text/plain")]
        request
          = C.makeReq "DELETE" "v1.0.0" [["post"], readId post] [] rHeaders ""
      in C.doRequest C.fromXML (const ()) request