diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2014, Alp Mestanogullari + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Alp Mestanogullari nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/servant.cabal b/servant.cabal new file mode 100644 --- /dev/null +++ b/servant.cabal @@ -0,0 +1,37 @@ +name: servant +version: 0.1 +synopsis: A library to generate REST-style webservices on top of scotty, handling all the boilerplate for you +description: + An abstraction for 'Resource's that can support any number + of operations, which will be tagged at the type-level. + . + This package however does provide standard /REST-y/ operations + ('Servant.Operation.Add', 'Servant.Operation.Delete', 'Servant.Operation.ListAll' + , 'Servant.Operation.Update' and 'Servant.Operation.View') and lets you define your + own. + . + You can then actually make a service out of a 'Servant.Resource.Resource' description + using any backend you like (we currently only provide a + backend in + the /servant-scotty/ package). +homepage: http://github.com/zalora/servant +license: BSD3 +license-file: LICENSE +author: Alp Mestanogullari +maintainer: alp@zalora.com +copyright: 2014 Zalora SEA +category: Web, Database +build-type: Simple +cabal-version: >=1.10 + +library + exposed-modules: + Servant.Context + , Servant.Error + , Servant.Prelude + , Servant.Resource + build-depends: + base >=4 && <5 + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall diff --git a/src/Servant/Context.hs b/src/Servant/Context.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Context.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE RankNTypes #-} +{- | +Module : Servant.Context +Copyright : (c) Zalora SEA 2014 +License : BSD3 +Maintainer : Alp Mestanogullari +Stability : experimental + +A 'Context' type for holding a function +that will use some /context/ to execute +something analoguous to a /database operation/. + +This is equivalent to holding something like: + +> withConnection someConnection + +where you have previously set up @someConnection@ by specifying a +connection string or something like that. This lets us support +any kind of backend (even an in-memory Map in an /IORef/), and +most interestingly, we can use just raw connections or a connection +pool, this approach really covers a lot of situations while keeping +everything quite simple. + +-} +module Servant.Context + ( Context + , mkContext + , withContext + ) where + +-- | A 'Context' is just a wrapper around a function +-- that can execute IO operations /given/ +-- this context. +newtype Context c + = Context { withctx :: forall r. (c -> IO r) -> IO r } + +-- | Create a 'Context' from a suitable function +mkContext :: (forall r. (c -> IO r) -> IO r) + -> Context c +mkContext = Context + +-- | Use the 'Context' to actually perform an 'IO' +-- operation requiring it. +withContext :: Context c + -> (c -> IO r) + -> IO r +withContext = withctx diff --git a/src/Servant/Error.hs b/src/Servant/Error.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Error.hs @@ -0,0 +1,94 @@ +{-# LANGUAGE ExistentialQuantification #-} +{- | +Module : Servant.Error +Copyright : (c) Zalora SEA 2014 +License : BSD3 +Maintainer : Alp Mestanogullari +Stability : experimental + +Everything you'll need when doing some kind of exception handling +around your \"database operations\". +-} +module Servant.Error + ( -- * Creating an combining 'ExceptionCatcher's + ExceptionCatcher + , noCatch + , catchAnd + , combineCatchers + + , -- * Running 'IO' actions against an 'ExceptionCatcher' + handledWith + ) where + +import Control.Exception +import Data.Monoid + +-- | A container for zero or more "exception catchers". +-- +-- By exception catcher, we mean here a function that can convert +-- some precise instance of 'Exception' to the error type used in +-- your scotty app (the @e@ type in "Servant.Resource" "Servant.Service") +newtype ExceptionCatcher err = + EC [Catcher err] + +-- a handy type for representing a single function that can catch +-- some (specific) exception. +-- The dictionary for the corresponding 'Exception' instance is packed +-- along with the function in this data type. +data Catcher err = forall exc. Exception exc => Catcher (exc -> err) + +-- | Don't catch any exception. +noCatch :: ExceptionCatcher err +noCatch = EC [] + +-- | Combine two 'ExceptionCatcher'. +-- +-- The resulting 'ExceptionCatcher' will be able to catch +-- exceptions using the /catchers/ from both arguments. +combineCatchers :: ExceptionCatcher err + -> ExceptionCatcher err + -> ExceptionCatcher err +combineCatchers (EC c1s) (EC c2s) = EC (c1s ++ c2s) + +-- | If you're into 'Monoid's, enjoy our +-- 'mempty' ('noErrorHandling') and '<>' ('combineCatchers'). +instance Monoid (ExceptionCatcher err) where + mempty = noCatch + + mappend = combineCatchers + +-- | Run an 'IO' action by watching for all the exceptions +-- supported by the 'ExceptionCatcher'. +-- +-- If an exception is thrown somewhere in the action and is caught +-- by the catcher, it will call the function given to 'catchAnd' +-- to convert the exception value to the error type of your scotty application. +-- +-- If an exception is thrown whose type isn't one for which there's a /catcher/ +-- in the 'ExceptionCatcher' argument, you'll have to catch it yourself or let it +-- be sent to the default handler. +-- +-- Since 'Servant.Service.runService' sets up a 'defaultHandler', you'll most +-- likely want to directly use 'raiseIfExc' which 'raise's the error value +-- you got from the exception if some exception is thrown or just run some +-- scotty action if everything went smoothly. This means writing a handler +-- that'll set up a response with the proper HTTP status and send some JSON +-- to the client with an informative error message, which... isn't a bad thing :-) +handledWith :: IO a -> ExceptionCatcher err -> IO (Either err a) +handledWith act (EC hs) = fmap Right act `catches` map runCatcher hs + + where runCatcher :: Catcher err -> Handler (Either err a) + runCatcher (Catcher f) = Handler $ return . Left . f + +-- | Create an 'ExceptionCatcher' from a function. +-- +-- This will make the catcher aware of exceptions of type @except@ +-- so that when you'll run a catcher against an 'IO' action +-- using 'raiseIfExc' or 'handledWith', if an exception of this type +-- is thrown, it will be caught and converted to the error type of your +-- web application using the provided function. +catchAnd :: Exception except + => (except -> err) + -> ExceptionCatcher err +catchAnd f = EC [catcher] + where catcher = Catcher f diff --git a/src/Servant/Prelude.hs b/src/Servant/Prelude.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Prelude.hs @@ -0,0 +1,163 @@ +{-# LANGUAGE TypeOperators, + ConstraintKinds, + MultiParamTypeClasses, + TypeFamilies, + TypeSynonymInstances, + DataKinds, + FlexibleContexts, + FlexibleInstances, + ScopedTypeVariables #-} +{- | +Module : Servant.Prelude +Copyright : (c) Zalora SEA 2014 +License : BSD3 +Maintainer : Alp Mestanogullari +Stability : experimental + +Some standard REST-y operations your 'Resource's can +support out of the box. + +Your type will have to implement a couple of class instances +to be usable with a backend. For the scotty backend, this means +having 'FromJSON' or 'ToJSON' instances and the appropriate +'toResponse' implementations for the return types of your +database. +-} +module Servant.Prelude + ( -- * Defining 'Resource's + module Servant.Resource + , module Servant.Context + , module Servant.Error + + , -- * Standard operations + Add + , addWith + , Delete + , deleteWith + , ListAll + , listAllWith + , Update + , updateWith + , View + , viewWith + ) where + +import Servant.Context +import Servant.Error +import Servant.Resource + +-- | A dummy type representing an operation that adds an entry. +data Add +instance Show Add where show _ = "Add" + +-- | A dummy type representing an operation that deletes an entry. +data Delete +instance Show Delete where show _ = "Delete" + +-- | A dummy type representing an operation that lists all entries. +data ListAll +instance Show ListAll where show _ = "ListAll" + +-- | A dummy type representing an operation that updates an entry. +data Update +instance Show Update where show _ = "Update" + +-- | A dummy type representing an operation that looks up an entry. +data View +instance Show View where show _ = "View" + +-- | To 'Add' an entry, we require a function of type @c -> a -> IO r@. +type instance Operation Add c a i r = a -> c -> IO (r Add) +-- | To 'Delete' an entry, we require a function of type @c -> i -> IO r@. +type instance Operation Delete c a i r = i -> c -> IO (r Delete) +-- | To 'List' all entries, we require a function of type @c -> IO [a]@. +type instance Operation ListAll c a i r = c -> IO [a] +-- | To 'Update' an entry, we require a function of type @c -> i -> a -> IO r@. +type instance Operation Update c a i r = i -> a -> c -> IO (r Update) +-- | To 'View' an entry, we require a function of type @c -> i -> IO (Maybe a)@. +type instance Operation View c a i r = i -> c -> IO (Maybe a) + +-- | Make a 'Resource' support the 'Add' +-- operation by using your function. +-- +-- Given: +-- +-- > addPerson :: PGSQL.Connection -> Person -> IO Bool +-- +-- you could do: +-- +-- > mkResource "persons" postgresContext noErrorHandling +-- > & addWith addPerson +addWith :: Contains Add ops ~ False + => (a -> c -> IO (r Add)) + -> Resource c a i r e ops + -> Resource c a i r e (Add ': ops) +addWith = addOperation + +-- | Make a 'Resource' support the 'Delete' +-- operation by using your function. +-- +-- Given: +-- +-- > deletePerson :: PGSQL.Connection -> PersonId -> IO Bool +-- +-- you could do: +-- +-- > mkResource "persons" postgresContext noErrorHandling +-- > & deleteWith addPerson +deleteWith :: Contains Delete ops ~ False + => (i -> c -> IO (r Delete)) + -> Resource c a i r e ops + -> Resource c a i r e (Delete ': ops) +deleteWith = addOperation + +-- | Make a 'Resource' support the 'ListAll' +-- operation by using your function. +-- +-- Given: +-- +-- > listAllPersons :: PGSQL.Connection -> IO [Person] +-- +-- you could do: +-- +-- > mkResource "persons" postgresContext noErrorHandling +-- > & listAllWith listAllPersons +listAllWith :: Contains ListAll ops ~ False + => (c -> IO [a]) + -> Resource c a i r e ops + -> Resource c a i r e (ListAll ': ops) +listAllWith = addOperation + +-- | Make a 'Resource' support the 'Update' +-- operation by using your function. +-- +-- Given: +-- +-- > updatePerson :: PGSQL.Connection -> PersonId -> Person -> IO Bool +-- +-- you could do: +-- +-- > mkResource "persons" postgresContext noErrorHandling +-- > & updateWith updatePerson +updateWith :: Contains Update ops ~ False + => (i -> a -> c -> IO (r Update)) + -> Resource c a i r e ops + -> Resource c a i r e (Update ': ops) +updateWith = addOperation + +-- | Make a 'Resource' support the 'View' +-- operation by using your function. +-- +-- Given: +-- +-- > viewPerson :: PGSQL.Connection -> PersonId -> IO (Maybe Person) +-- +-- you could do: +-- +-- > mkResource "persons" postgresContext noErrorHandling +-- > & viewWith viewPerson +viewWith :: Contains View ops ~ False + => (i -> c -> IO (Maybe a)) + -> Resource c a i r e ops + -> Resource c a i r e (View ': ops) +viewWith = addOperation diff --git a/src/Servant/Resource.hs b/src/Servant/Resource.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Resource.hs @@ -0,0 +1,193 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +{- | +Module : Servant.Resource +Copyright : (c) Zalora SEA 2014 +License : BSD3 +Maintainer : Alp Mestanogullari +Stability : experimental + +Defining 'Resource's. +-} +module Servant.Resource + ( Resource + , name + , context + , excCatcher + , withHeadOperation + , dropHeadOperation + , mkResource + , addOperation + , Operation + , (&) + , Ops + , Contains + ) where + +import Servant.Context +import Servant.Error + +-- | Heterogeneous list +data HList :: [*] -> * where + Nil :: HList '[] + Cons :: a -> HList as -> HList (a ': as) + +hhead :: HList (a ': as) -> a +hhead (Cons h _) = h + +-- | Get the tail of an heterogeneous list +htail :: HList (a ': as) -> HList as +htail (Cons _ t) = t + +-- | Utility (closed) type family to detect whether a type +-- is contained in a type-level list of types +#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 781 +type family Contains (elem :: *) (list :: [*]) :: Bool where + Contains elem '[] = False + Contains elem (elem ': xs) = True + Contains elem (x ': xs) = Contains elem xs +#else +type Contains (elem :: *) (list :: [*]) = False +#endif + +-- | A resource that: +-- +-- * uses some context type @c@ (think database connection) +-- * manages entries of type @a@ +-- * (optionally) supports indexing through the @i@ type (a dumb ID, or something like +-- @data FooId = ByToken Token | ByID Integer@). That can be useful when trying to view, +-- update or delete a particular entry, for example. +-- * uses @r@ as the return type (tagged by the operation type) for /effectful/ database operations (e.g. adding, updating, deleting entries +-- for example). +-- * can catch exceptions, converting them to some error type +-- @e@ of yours +-- * supports the operations listed in the @ops@ type list. a corresponding +-- (heterogeneous) list of "database functions" is held internally and we +-- ask the compiler to make the types of these functions match with the ones +-- expected for the operations listed at the type-level. +data Resource c a i (r :: * -> *) e (ops :: [*]) + = Resource { name :: String -- ^ Get the name of the 'Resource' + , context :: Context c -- ^ Gives the 'Context' attached to this 'Resource' + , excCatcher :: ExceptionCatcher e -- ^ Hands you the 'ExceptionCatcher' you can + -- 'handledWith' with to make your \"database operations\" + -- exception safe. + , operations :: HList (Ops ops c a i r) + } + +instance Show (Resource c a i r e '[]) where + show r = name r + +instance (Show o, Show (Resource c a i r e ops)) + => Show (Resource c a i r e (o ': ops)) where + show r = + show (dropHeadOperation r) ++ + opstring + + where opstring = "\n - " ++ show (undefined :: o) + +-- | Typically, functions that will use our operations will need access +-- to the resource's name and what not, so we need to provide them with +-- the resource. But we obviously also need the \"database function\" +-- associated to our operation. So we provide it too. +-- +-- Just give this function a 'Resource' and a function that uses it, +-- most likely to run the handler for an operation, +-- and it'll give your function the right arguments. +withHeadOperation :: Resource c a i r e (o ': ops) + -> (Resource c a i r e (o ': ops) -> Operation o c a i r -> b) + -> b +withHeadOperation res runop = + runop res (hhead $ operations res) + +-- | Type-safely \"unconsider\" the first operation in the list +-- +-- Helpful when performing recursion on the type-level list +-- and the internal list of \"database functions\" +-- simultaneously. +dropHeadOperation :: Resource c a i r e (o ': ops) -> Resource c a i r e ops +dropHeadOperation r = r { operations = operations' } + + where operations' = htail (operations r) + +-- | Create an /empty/ resource that doesn't support any operation +-- and catches exceptions using the given 'ExceptionCatcher'. +-- Any operation supported later on can make use of the provided +-- 'Context', by simply doing: +-- +-- > withContext (context resource) $ \c -> ... +-- +-- where @c@ could be a PostgreSQL connection, for example. +mkResource :: String + -> Context c + -> ExceptionCatcher e + -> Resource c a i r e '[] +mkResource n ctx catcher = Resource n ctx catcher Nil + +-- | Add an operation to a resource by specifying the \"database function\" +-- that'll actually perform the lookup, update, listing, search and what not. +-- +-- We statically enforce that the operation we're adding isn't +-- already supported by the 'Resource', when built with @ghc >= 7.8@. +addOperation :: Contains o ops ~ False + => Operation o c a i r + -> Resource c a i r e ops + -> Resource c a i r e (o ': ops) +addOperation opfunc resource = + resource { operations = Cons opfunc (operations resource) } + +-- | Type level 'map'-like function that replaces an operation's tag +-- by the type of the associated \"database function\" +-- +-- For example: +-- +-- > Ops [Add, List] c a i r +-- +-- will result in: +-- +-- > [ a -> c -> IO r -- what 'Add' is replaced by +-- > , c -> IO [a] -- what 'List' is replaced by +-- > ] +-- +-- This is useful as we can exactly determine the type of the heterogeneous +-- list that holds the actual \"dtabase functions\" that will perform the +-- operations, using 'Ops'. This among other things enforces a strong +-- correspondance between the type-level list of operations and the +-- (heterogeneous) list of functions held in the 'Resource' we're interested in. +-- +-- That means we can't magically convert a 'Resource' into one that supports one more +-- operations without registering a function for it (which /must have/ the right type, +-- or your code won't compile. +type family Ops (ops :: [*]) c a i (r :: * -> *) :: [*] +type instance Ops (o ': ops) c a i r = Operation o c a i r ': Ops ops c a i r +type instance Ops '[] c a i r = '[] + +-- | Map an operation tag @o@ to some combination of the other type +-- parameters. +-- +-- For instance, if we look at 'Add', we know that we'll need our +-- \"connection type\" @c@ and a value to add, of type @a@. The result will +-- be of type @IO (r Add)@. If we put this all together, we get: +-- +-- > type instance Operation Add c a i r = a -> c -> IO (r Add) +-- +-- Whereas for listing all entries ('ListAll'), we just want some kind +-- of connection @c@ and we get back @[a]@. +-- +-- > type instance Operation ListAll c a i r = c -> IO [a] +type family Operation o c a i (r :: * -> *) :: * + +-- | Reversed function application. +-- +-- > x & f = f x +(&) :: a -> (a -> b) -> b +x & f = f x +{-# INLINE (&) #-}