rest-core (empty) → 0.27.0.1

raw patch · 20 files changed

+2417/−0 lines, 20 filesdep +HUnitdep +aesondep +aeson-utilssetup-changed

Dependencies added: HUnit, aeson, aeson-utils, base, bytestring, cgi, containers, either, errors, fclabels, hxt, hxt-pickle-utils, json-schema, mtl, random, rest-core, rest-types, safe, split, test-framework, test-framework-hunit, text, tostring, transformers, uri-encode, utf8-string, uuid

Files

• LICENSE +30/−0
• Setup.hs +2/−0
• rest-core.cabal +72/−0
• src/Rest.hs +26/−0
• src/Rest/Api.hs +167/−0
• src/Rest/Container.hs +109/−0
• src/Rest/Dictionary.hs +23/−0
• src/Rest/Dictionary/Combinators.hs +195/−0
• src/Rest/Dictionary/Types.hs +205/−0
• src/Rest/Driver/Perform.hs +384/−0
• src/Rest/Driver/RestM.hs +80/−0
• src/Rest/Driver/Routing.hs +347/−0
• src/Rest/Driver/Types.hs +16/−0
• src/Rest/Error.hs +47/−0
• src/Rest/Handler.hs +172/−0
• src/Rest/Info.hs +31/−0
• src/Rest/Resource.hs +100/−0
• src/Rest/Run.hs +24/−0
• src/Rest/Schema.hs +181/−0
• tests/Runner.hs +206/−0

@@ -0,0 +1,30 @@+Copyright (c) 2014, Silk++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 Silk 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.

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,72 @@+Name:             rest-core+Version:          0.27.0.1+Description:      Rest API library.+Synopsis:         Rest API library.+Maintainer:       code@silk.co+Category:         Web+Build-Type:       Simple+Cabal-Version:    >= 1.8+License:          BSD3+License-File:     LICENSE++Library+  GHC-Options:     -Wall+  Hs-Source-Dirs:   src+  Build-Depends:+      base                      == 4.*+    , bytestring                >= 0.9    &&  < 0.11+    , cgi                       == 3001.1.8.101+    , containers                >= 0.3    &&  < 0.6+    , either                    >= 3.4    &&  < 4.2+    , errors                    == 1.4.*+    , fclabels                  == 2.0.*+    , hxt                       >= 9.2    &&  < 9.4+    , aeson                     >= 0.7    &&  < 0.8+    , aeson-utils               == 0.2.*+    , json-schema               == 0.4.*+    , mtl                       >= 2.0    &&  < 2.2+    , random                    == 1.0.*+    , hxt-pickle-utils          == 0.1.*+    , rest-types                == 1.9.0.1+    , safe                      >= 0.2    &&  < 0.4+    , split                     >= 0.1    &&  < 0.3+    , text                      >= 0.11   &&  < 1.2+    , tostring                  == 0.2.*+    , transformers              >= 0.2    &&  < 0.4+    , uri-encode                == 1.5.*+    , utf8-string               == 0.3.*+    , uuid                      >= 1.2    &&  < 1.4++  Exposed-Modules:  Rest+                    Rest.Api+                    Rest.Container+                    Rest.Dictionary+                    Rest.Dictionary.Combinators+                    Rest.Dictionary.Types+                    Rest.Driver.Perform+                    Rest.Driver.RestM+                    Rest.Driver.Routing+                    Rest.Driver.Types+                    Rest.Error+                    Rest.Handler+                    Rest.Info+                    Rest.Resource+                    Rest.Run+                    Rest.Schema++Test-suite rest-tests+  build-depends:       base                 >= 4.5    && < 4.7+                     , HUnit                == 1.2.*+                     , bytestring           >= 0.9    && < 0.11+                     , mtl                  >= 2.0    && < 2.2+                     , rest-core+                     , test-framework       == 0.8.*+                     , test-framework-hunit == 0.3.*+  hs-source-dirs:      tests+  main-is:             Runner.hs+  type:                exitcode-stdio-1.0+  ghc-options:         -Wall++Source-repository head+  Type:              Git+  Location:          https://github.com/silkapp/rest.git

@@ -0,0 +1,26 @@+-- | These modules allow you to define a single REST resource. Then,+-- you can combine multiple resources into an API using "Rest.Api",+-- and run them using 'rest-happstack' or 'rest-snap', or generate+-- client code or documentation using 'rest-gen'.+module Rest+  ( -- | Creating a 'Resource'.+    module Rest.Resource+    -- | Defining the routing schema.+  , module Rest.Schema+    -- | Defining 'Handler's for endpoints in the resource.+  , module Rest.Handler+    -- | Combinators for defining input and ouput dictionaries of+    -- handlers.+  , module Rest.Dictionary.Combinators+    -- | Working with errors returned from handlers.+  , module Rest.Error+  ) where++import Rest.Dictionary.Combinators+import Rest.Error+import Rest.Handler ( Env (..), Handler, ListHandler, secureHandler+                    , Range (..), range, mkListing, mkOrderedListing, mkHandler+                    , mkInputHandler, mkConstHandler, mkIdHandler+                    )+import Rest.Resource (Resource, mkResource, mkResourceId, mkResourceReader, mkResourceReaderWith, Void)+import Rest.Schema

@@ -0,0 +1,167 @@+{-# LANGUAGE+    GADTs+  , KindSignatures+  #-}+-- | This module allows you to combine 'Resource's into an 'Api'. This+-- can then be served using 'rest-happstack' or 'rest-snap', or used+-- to generate clients or documentation using 'rest-gen'.+module Rest.Api+  ( -- * Api data types.+    Api+  , Router (..)+  , Some1 (..)++    -- * Defining routes.+  , route+  , compose+  , (     -/)+  , (    --/)+  , (   ---/)+  , (  ----/)+  , ( -----/)+  , (------/)+  , root++    -- * Api versioning.+  , Version (..)+  , mkVersion+  , latest+  , parseVersion+  , lookupVersion+  , lookupVersion'+  , withVersion+  ) where++import Control.Applicative (Applicative)+import Data.Char+import Data.Function (on)+import Data.List (sortBy)+import Data.List.Split+import Data.Ord (comparing)++import Rest.Resource+import Rest.Schema (named, singleton)+++import Safe++-------------------------------------------------------------------------------+-- A routing table of REST resources.++-- | An existential where the second argument has kind @(* -> *)@.++data Some1 f where Some1 :: f (a :: * -> *) -> Some1 f++-- | A 'Router' is a 'Resource' and a list of subresources.++data Router m s where+  Embed :: Resource m s sid mid aid -> [Some1 (Router s)] -> Router m s++-- | Convenience constructor constructing a route without any+-- subresource.++route :: Monad s => Resource m s sid mid aid -> Router m s+route = flip Embed []++-- | Add the second router as a subresource to the first.++compose :: Router m s -> Router s t -> Router m s+compose (Embed r xs) b = Embed r (xs ++ [Some1 b])++infixl 4 -/+infixl 5 --/+infixl 6 ---/+infixl 7 ----/+infixl 8 -----/+infixl 9 ------/++-- | Operators with the right fixities to allow you to define routes+-- without using parentheses. Start with the shortest near the root.++(-/), (--/), (---/), (----/), (-----/), (------/) :: Router m s -> Router s t -> Router m s++(     -/) = compose+(    --/) = compose+(   ---/) = compose+(  ----/) = compose+( -----/) = compose+(------/) = compose++-- | An empty router to use as the root for your API.++root :: (Applicative m, Monad m) => Router m m+root = route $ mkResourceId { schema = singleton () $ named [] }++-------------------------------------------------------------------------------++-- | An API version has three parts. The first is two are used for API+-- breaking changes, the last for non-API breaking changes.++data Version = Version+  { full  :: Int+  , major :: Int+  , minor :: Maybe Int+  } deriving (Eq, Ord)++-- | Smart constructor for 'Version'.++mkVersion :: Int -> Int -> Int -> Version+mkVersion f m l = Version f m (Just l)++instance Show Version where+  show v = show (full v) ++ "." ++ show (major v) ++ maybe "" (\x -> "." ++ show x) (minor v)++-- | An API is a list of versioned routers.++type Api m = [(Version, Some1 (Router m))]++-- | Get the latest version of an API.++latest :: Api m -> Maybe (Version, Some1 (Router m))+latest = headMay . reverse . sortBy (compare `on` fst)++-- | Parse a 'String' as a 'Version'. The string should contain two or+-- three numbers separated by dots, e.g. @1.12.3@.++parseVersion :: String -> Maybe Version+parseVersion s =+  case map readMay . splitOn "." . filter (\c -> isDigit c || c == '.') $ s of+    [ Just a, Just b, Just c ] -> Just (Version a b (Just c))+    [ Just a, Just b         ] -> Just (Version a b Nothing)+    _                          -> Nothing++-- | Look up a version in an API. The string can either be a valid+-- version according to 'parseVersion', or "latest".++lookupVersion :: String -> Api m -> Maybe (Some1 (Router m))+lookupVersion "latest" = fmap snd . latest+lookupVersion str      = (parseVersion str >>=) . flip lookupVersion'++-- | Look up a version in the API.++lookupVersion' :: Version -> Api m -> Maybe (Some1 (Router m))+lookupVersion' v versions = best (filter (matches v . fst) versions)+  where best = fmap snd . headMay . sortBy (flip (comparing fst))+        matches :: Version -> Version -> Bool+        matches (Version a b c) (Version x y z)+          | a == x && b == y && c <= z = True+          | otherwise                  = False++-- | Given a version string, an API and a fallback, do the following:+--+-- * Parse the version number or "latest".+--+-- * Look up this version.+--+-- * If ok, run the given function on it.+--+-- * If not parsed or found, return the fallback.++withVersion :: String -> Api m -> r -> (Version -> Some1 (Router m) -> r) -> r+withVersion ver api err ok =+  maybe err (uncurry ok) $+    case ver of+      "latest" -> latest api+      _        -> do pv <- parseVersion ver+                     r <- lookupVersion' pv api+                     return (pv, r)

@@ -0,0 +1,109 @@+{-# LANGUAGE+    TemplateHaskell+  , EmptyDataDecls+  , TypeFamilies+  , FlexibleInstances+  , ScopedTypeVariables+  , DeriveDataTypeable+  , GADTs+  #-}+module Rest.Container+  ( module Rest.Types.Container+  , listI+  , listO+  , mappingI+  , mappingO+  , statusO+  , reasonE+  ) where++import Data.Maybe+import Data.String+import Data.String.ToString+import Data.Typeable++import Rest.Dictionary+import Rest.Error+import Rest.Types.Container++listI :: Inputs a -> Maybe (Inputs (List a))+listI None       = Just (Dicts [XmlI, JsonI])+listI (Dicts is) =+  case mapMaybe listDictI is of+    []  -> Nothing+    lis -> Just (Dicts lis)+  where+    listDictI :: Input a -> Maybe (Input (List a))+    listDictI XmlI  = Just XmlI+    listDictI JsonI = Just JsonI+    listDictI _     = Nothing++listO :: Outputs a -> Maybe (Outputs (List a))+listO None       = Just (Dicts [XmlO, JsonO])+listO (Dicts os) =+  case mapMaybe listDictO os of+    []  -> Nothing+    los -> Just (Dicts los)+  where+    listDictO :: Output a -> Maybe (Output (List a))+    listDictO XmlO  = Just XmlO+    listDictO JsonO = Just JsonO+    listDictO _     = Nothing++mappingI :: forall k i. (Typeable k, IsString k, ToString k) => Inputs i -> Maybe (Inputs (StringMap k i))+mappingI None       = Just (Dicts [XmlI, JsonI])+mappingI (Dicts is) =+  case mapMaybe mappingDictI is of+    []  -> Nothing+    mis -> Just (Dicts mis)+  where+    mappingDictI :: Input i -> Maybe (Input (StringMap k i))+    mappingDictI XmlI  = Just XmlI+    mappingDictI JsonI = Just JsonI+    mappingDictI _     = Nothing++mappingO :: forall k o. (Typeable k, IsString k, ToString k) => Outputs o -> Maybe (Outputs (StringMap k o))+mappingO None       = Just (Dicts [XmlO, JsonO])+mappingO (Dicts os) =+  case mapMaybe mappingDictO os of+    []  -> Nothing+    mos -> Just (Dicts mos)+  where+    mappingDictO :: Output o -> Maybe (Output (StringMap k o))+    mappingDictO XmlO  = Just XmlO+    mappingDictO JsonO = Just JsonO+    mappingDictO _     = Nothing++statusO :: Errors e -> Outputs o -> Maybe (Outputs (Status e o))+statusO None       None       = Just (Dicts [XmlO, JsonO])+statusO None       (Dicts os) = mkStatusDict [XmlE, JsonE] os+statusO (Dicts es) None       = mkStatusDict es           [XmlO, JsonO]+statusO (Dicts es) (Dicts os) = mkStatusDict es           os++mkStatusDict :: forall e o. [Error e] -> [Output o] -> Maybe (Outputs (Status e o))+mkStatusDict es os =+    case mapMaybe mappingDictO (intersect es os) of+      []  -> Nothing+      sos -> Just (Dicts sos)+    where+      mappingDictO :: (Error e, Output o) -> Maybe (Output (Status e o))+      mappingDictO (XmlE , XmlO ) = Just XmlO+      mappingDictO (JsonE, JsonO) = Just JsonO+      mappingDictO _              = Nothing++intersect :: [Error e] -> [Output o] -> [(Error e, Output o)]+intersect [] _  = []+intersect _  [] = []+intersect es os = [ (e, o) | e <- es, o <- os, e `eq` o ]+  where+    XmlE  `eq` XmlO  = True+    JsonE `eq` JsonO = True+    _     `eq` _     = False++reasonE :: Errors a -> Errors (Reason a)+reasonE None       = Dicts [XmlE, JsonE]+reasonE (Dicts es) = Dicts (map reasonDictE es)+  where+    reasonDictE :: Error a -> Error (Reason a)+    reasonDictE XmlE  = XmlE+    reasonDictE JsonE = JsonE

@@ -0,0 +1,23 @@+{-|+A dictionary (`Dict`) describes how to convert Haskell values to and from a web+representation. Rest resources internally use plain Haskell datatypes, while+communication to the outside world mostly happens using XML, JSON, plain text,+query parameters, etc. The `Dict` datatype describes how to convert resource+/indentifiers, input, request parameters, request headers, output, and errors/+to and from a Haskell representation.++The `Dict` datatype and most functions working on it take a type parameters for+every aspect of its communication, which can grow quickly. This module and+most code that depend on it uses the implicit convention of using the type+variable `id` for the resource identifier, the `h` for the request headers, the+`p` for the request parameters, the `i` for the request body, the `o` for the+response body, and the `e` for a possible error.+-}++module Rest.Dictionary+  ( module Rest.Dictionary.Types+  , module Rest.Dictionary.Combinators+  ) where++import Rest.Dictionary.Types+import Rest.Dictionary.Combinators

@@ -0,0 +1,195 @@+-- | Combinators for specifying the input/output dictionaries of a+-- 'Handler'. The combinators can be combined using @(@'.'@)@.+module Rest.Dictionary.Combinators+  (+  -- ** Input dictionaries++    someI+  , stringI+  , xmlTextI+  , fileI+  , readI+  , xmlI+  , rawXmlI+  , jsonI++  -- ** Output dictionaries++  , someO+  , stringO+  , fileO+  , xmlO+  , rawXmlO+  , jsonO+  , multipartO++  -- ** Error dictionaries++  , someE+  , jsonE+  , xmlE++  -- ** Composed dictionaries++  , xmlJsonI+  , xmlJsonO+  , xmlJsonE+  , xmlJson++  -- ** Header dictionaries++  , mkHeader++  -- ** Parameter dictionaries++  , mkPar+  , addPar+  ) where++import Prelude hiding (id, (.))++import Control.Category+import Data.Aeson+import Data.ByteString.Lazy (ByteString)+import Data.JSON.Schema+import Data.Text.Lazy (Text)+import Data.Typeable+import Network.CGI.Multipart (BodyPart)+import Text.XML.HXT.Arrow.Pickle+import qualified Data.Label.Total as L++import Rest.Dictionary.Types+import Rest.Info++-- | Add custom sub-dictionary for recognizing headers.++mkHeader :: Header h -> Dict x p i o e -> Dict h p i o e+mkHeader = L.set headers++-- | Set custom sub-dictionary for recognizing parameters.++mkPar :: Param p -> Dict h x i o e -> Dict h p i o e+mkPar = L.set params++-- | Add custom sub-dictionary for recognizing parameters.++addPar :: Param p -> Dict h p' i o e -> Dict h (p, p') i o e+addPar = L.modify params . TwoParams++-- | Open up input type for extension with custom dictionaries.++someI :: Dict h p () o e -> Dict h p i o e+someI = L.set inputs (Dicts [])++-- | Allow direct usage of as input as `String`.++stringI :: Dict h p i o e -> Dict h p String o e+stringI = L.set inputs (Dicts [StringI])++-- | Allow direct usage of as input as raw Xml `Text`.++xmlTextI :: Dict h p i o e -> Dict h p Text o e+xmlTextI = L.set inputs (Dicts [XmlTextI])++-- | Allow usage of input as file contents, represented as a `ByteString`.++fileI :: Dict h p i o e -> Dict h p ByteString o e+fileI = L.set inputs (Dicts [FileI])++-- | The input can be read into some instance of `Read`. For inspection reasons+-- the type must also be an instance of both `Info` and `Show`.++readI :: (Info i, Read i, Show i) => Dict h p i o e -> Dict h p i o e+readI = L.modify (dicts . inputs) (ReadI:)++-- | The input can be read into some instance of `XmlPickler`.++xmlI :: (Typeable i, XmlPickler i) => Dict h p i o e -> Dict h p i o e+xmlI = L.modify (dicts . inputs) (XmlI:)++-- | The input can be used as an XML `ByteString`.++rawXmlI :: Dict h p i o e -> Dict h p ByteString o e+rawXmlI = L.set inputs (Dicts [RawXmlI])++-- | The input can be read into some instance of `Json`.++jsonI :: (Typeable i, FromJSON i, JSONSchema i) => Dict h p i o e -> Dict h p i o e+jsonI = L.modify (dicts . inputs) (JsonI:)++-- | Open up output type for extension with custom dictionaries.++someO :: Dict h p i () e -> Dict h p i o e+someO = L.set outputs (Dicts [])++-- | Allow output as plain String.++stringO :: Dict h p i () e -> Dict h p i String e+stringO = L.set outputs (Dicts [StringO])++-- | Allow file output using a combination of the raw data and a mime type.++fileO :: Dict h p i o e -> Dict h p i (ByteString, String) e+fileO = L.set outputs (Dicts [FileO])++-- | Allow output as XML using the `XmlPickler` type class.++xmlO :: (Typeable o, XmlPickler o) => Dict h p i o e -> Dict h p i o e+xmlO = L.modify (dicts . outputs) (XmlO:)++-- | Allow output as raw XML represented as a `ByteString`.++rawXmlO :: Dict h p i () e -> Dict h p i ByteString e+rawXmlO = L.set outputs (Dicts [RawXmlO])++-- | Allow output as JSON using the `Json` type class.++jsonO :: (Typeable o, ToJSON o, JSONSchema o) => Dict h p i o e -> Dict h p i o e+jsonO = L.modify (dicts . outputs) (JsonO:)++-- | Allow output as multipart. Writes out the ByteStrings separated+-- by boundaries, with content type 'multipart/mixed'.++multipartO :: Dict h p i () e -> Dict h p i [BodyPart] e+multipartO = L.set outputs (Dicts [MultipartO])++-- | Open up error type for extension with custom dictionaries.++someE :: (Typeable e, ToJSON e, JSONSchema e) => Dict h p i o () -> Dict h p i o e+someE = L.set errors (Dicts [])++-- | Allow error output as JSON using the `Json` type class.++jsonE :: (Typeable e, ToJSON e, JSONSchema e) => Dict h p i o e -> Dict h p i o e+jsonE = L.modify (dicts . errors) (JsonE:)++-- | Allow error output as XML using the `XmlPickler` type class.++xmlE :: (Typeable e, XmlPickler e) => Dict h p i o e -> Dict h p i o e+xmlE = L.modify (dicts . errors) (XmlE:)++-- | The input can be read into some instance of both `Json` and `XmlPickler`.++xmlJsonI :: (Typeable i, FromJSON i, JSONSchema i, XmlPickler i) => Dict h p () o e -> Dict h p i o e+xmlJsonI = xmlI . jsonI . someI++-- | Allow output as JSON using the `Json` type class and allow output as XML+-- using the `XmlPickler` type class.++xmlJsonO :: (Typeable o, ToJSON o, JSONSchema o, XmlPickler o) => Dict h p i () e -> Dict h p i o e+xmlJsonO = xmlO . jsonO . someO++-- | Allow error output as JSON using the `Json` type class and allow output as+-- XML using the `XmlPickler` type class.++xmlJsonE :: (Typeable e, ToJSON e, JSONSchema e, XmlPickler e) => Dict h p i o () -> Dict h p i o e+xmlJsonE = xmlE . jsonE . someE++-- | The input can be read into some instance of both `Json` and `XmlPickler`+-- and allow output as JSON using the `Json` type class and allow output as XML+-- using the `XmlPickler` type class.++xmlJson :: (Typeable i, FromJSON i, JSONSchema i, XmlPickler i+           ,Typeable o, ToJSON o, JSONSchema o, XmlPickler o)+        => Dict h p () () e -> Dict h p i o e+xmlJson = xmlJsonI . xmlJsonO

@@ -0,0 +1,205 @@+{-# LANGUAGE+    GADTs+  , StandaloneDeriving+  , TemplateHaskell+  , TypeOperators+  , FlexibleContexts+  #-}+module Rest.Dictionary.Types+  (+  -- * Possible I/O formats.++    Format (..)++  -- * The dictionary type.++  , Dict+  , headers+  , params+  , inputs+  , outputs+  , errors++  , empty+  , Modifier++  -- * Dictionary aspects.++  , Ident (..)+  , Header (..)+  , Param (..)+  , Input (..)+  , Output (..)+  , Error (..)++  -- * Plural dictionaries.++  , Dicts (..)+  , dicts+  , Inputs+  , Outputs+  , Errors+  , SomeError (..)++  )++where++import Data.Aeson+import Data.ByteString.Lazy (ByteString)+import Data.JSON.Schema+import Data.Label ((:->), lens)+import Data.Label.Derive+import Data.Text.Lazy (Text)+import Data.Typeable+import Network.CGI.Multipart (BodyPart)+import Text.XML.HXT.Arrow.Pickle++import Rest.Error+import Rest.Info++-- | The `Format` datatype enumerates all input and output formats we might recognize.++data Format+  = XmlFormat+  | JsonFormat+  | StringFormat+  | FileFormat+  | MultipartFormat+  | NoFormat+  deriving (Eq, Ord, Enum, Bounded, Show)++-- | The explicit dictionary `Ident` describes how to translate a resource+-- identifier (originating from a request URI) to a Haskell value. We allow+-- plain `String` identifiers or all Haskell types that have a `Read` instance.++data Ident id where+  ReadId   :: (Info id, Read id, Show id) => Ident id+  StringId ::                                Ident String++deriving instance Show (Ident id)++-- | The explicit dictionary `Header` describes how to translate HTTP request+-- headers to some Haskell value. The first field in the `Header` constructor+-- is a white list of headers we can recognize, used in generic validation and+-- for generating documentation. The second field is a custom parser that can+-- fail with a `DataError` or can produce a some value. When explicitly not+-- interested in the headers we can use `NoHeader`.+--+-- Todo: allow multiple parsers for different headers instead of combining them+-- into one parser + use `Info` class to enfore some documention about the+-- parsed type.++data Header h where+  NoHeader ::                                                       Header ()+  Header   :: [String] -> ([Maybe String] -> Either DataError h) -> Header h++-- | The explicit dictionary `Parameter` describes how to translate the request+-- parameters to some Haskell value. The first field in the `Header`+-- constructor is a white list of paramters we can recognize, used in generic+-- validation and for generating documentation. The second field is a custom+-- parser that can fail with a `DataError` or can produce a some value. When+-- explicitly not interested in the parameters we can use `NoParam`.+--+-- Todo: allow multiple parsers for different parameters instead of combining+-- them into one parser + use `Info` class to enfore some documention about the+-- parsed type.++data Param p where+  NoParam   ::                                                       Param ()+  Param     :: [String] -> ([Maybe String] -> Either DataError p) -> Param p+  TwoParams :: Param p -> Param q                                 -> Param (p, q)++-- | The explicitly dictionary `Input` describes how to translate the request+-- body into some Haskell value. We currently use a constructor for every+-- combination of input type to output type. For example, we can use XML input+-- in multiple ways, parsed, as plain/text or as raw bytes, depending on the+-- needs of the backend resource.++data Input i where+  JsonI    :: (Typeable i, FromJSON i, JSONSchema i) => Input i+  ReadI    :: (Info i, Read i, Show i)               => Input i+  StringI  ::                                           Input String+  FileI    ::                                           Input ByteString+  XmlI     :: (Typeable i, XmlPickler i)             => Input i+  XmlTextI ::                                           Input Text+  RawXmlI  ::                                           Input ByteString++deriving instance Show (Input i)+deriving instance Eq   (Input i)+deriving instance Ord  (Input i)++-- | The explicitly dictionary `Output` describes how to translate some Haskell+-- value to a response body. We currently use a constructor for every+-- combination of input type to output type.++data Output o where+  FileO      ::                                         Output (ByteString, String)+  RawXmlO    ::                                         Output ByteString+  JsonO      :: (Typeable o, ToJSON o, JSONSchema o) => Output o+  XmlO       :: (Typeable o, XmlPickler o)           => Output o+  StringO    ::                                         Output String+  MultipartO ::                                         Output [BodyPart]++deriving instance Show (Output o)+deriving instance Eq   (Output o)+deriving instance Ord  (Output o)++-- | The explicitly dictionary `Error` describes how to translate some Haskell+-- error value to a response body.++data Error e where+  JsonE   :: (Typeable e, ToJSON e, JSONSchema e) => Error e+  XmlE    :: (Typeable e, XmlPickler e)           => Error e++deriving instance Show (Error e)+deriving instance Eq   (Error e)+deriving instance Ord  (Error e)++type Inputs  i = Dicts Input  i+type Outputs o = Dicts Output o+type Errors  e = Dicts Error  e++data Dicts f a where+  None  :: Dicts f ()+  Dicts :: [f a] -> Dicts f a++deriving instance Show (f a) => Show (Dicts f a)++dicts :: Dicts f a :-> [f a]+dicts = lens getDicts modDicts+  where+    getDicts None       = []+    getDicts (Dicts ds) = ds+    modDicts :: ([f a] -> [f a]) -> Dicts f a -> Dicts f a+    modDicts _ None       = None+    modDicts f (Dicts ds) = Dicts (f ds)++-- | The `Dict` datatype containing sub-dictionaries for translation of+-- identifiers (i), headers (h), parameters (p), inputs (i), outputs (o), and+-- errors (e). Inputs, outputs and errors can have multiple associated+-- dictionaries.++fclabels [d|+  data Dict h p i o e = Dict+    { headers :: Header  h+    , params  :: Param   p+    , inputs  :: Inputs  i+    , outputs :: Outputs o+    , errors  :: Errors  e+    }+  |]++-- | The empty dictionary, recognizing no types.++empty :: Dict () () () () ()+empty = Dict NoHeader NoParam None None None++-- | Custom existential packing an error together with a Reason.++data SomeError where+  SomeError :: Errors e -> Reason e -> SomeError++-- | Type synonym for dictionary modification.++type Modifier h p i o e = Dict () () () () () -> Dict h p i o e

@@ -0,0 +1,384 @@+{-# LANGUAGE RankNTypes+           , GADTs+           , ScopedTypeVariables+           , OverloadedStrings+           #-}+module Rest.Driver.Perform where++import Control.Applicative+import Control.Monad+import Control.Monad.Cont+import Control.Monad.Error+import Control.Monad.RWS+import Control.Monad.Reader+import Control.Monad.State+import Control.Monad.Trans.Identity+import Control.Monad.Trans.Maybe (MaybeT (..))+import Control.Monad.Writer+import Data.Aeson.Utils+import Data.Char (isSpace, toLower)+import Data.List+import Data.List.Split+import Data.Maybe+import Data.Text.Lazy.Encoding (decodeUtf8)+import Data.UUID (UUID)+import Network.CGI.Multipart (showMultipartBody, MultiPart(..), BodyPart (..))+import Safe+import System.IO.Unsafe+import System.Random (randomIO)+import Text.Xml.Pickle++import qualified Control.Monad.Error       as E+import qualified Data.ByteString.Lazy      as B+import qualified Data.ByteString.Lazy.UTF8 as UTF8+import qualified Data.Label.Total          as L++import Rest.Dictionary ( Dict, Format (..)+                       , Param (..), Header (..), Input (..), Output (..), Error (..)+                       , Dicts (..), Inputs, Outputs, Errors+                       )+import Rest.Driver.Types+import Rest.Error+import Rest.Handler+import qualified Rest.Dictionary   as D+import qualified Rest.Driver.Types as Rest++class (Applicative m, Monad m) => Rest m where+  getHeader       :: String -> m (Maybe String)+  getParameter    :: String -> m (Maybe String)+  getBody         :: m (UTF8.ByteString)+  getMethod       :: m Rest.Method+  getPaths        :: m [String]+  lookupMimeType  :: String -> m (Maybe String)+  setHeader       :: String -> String -> m ()+  setResponseCode :: Int -> m ()++instance Rest m => Rest (ContT r m) where+  getHeader       = lift . getHeader+  getParameter    = lift . getParameter+  getBody         = lift getBody+  getMethod       = lift getMethod+  getPaths        = lift getPaths+  lookupMimeType  = lift . lookupMimeType+  setHeader nm    = lift . setHeader nm+  setResponseCode = lift . setResponseCode++instance (E.Error e, Rest m) => Rest (ErrorT e m) where+  getHeader       = lift . getHeader+  getParameter    = lift . getParameter+  getBody         = lift getBody+  getMethod       = lift getMethod+  getPaths        = lift getPaths+  lookupMimeType  = lift . lookupMimeType+  setHeader nm    = lift . setHeader nm+  setResponseCode = lift . setResponseCode++instance (Monoid w, Rest m) => Rest (RWST r w s m) where+  getHeader       = lift . getHeader+  getParameter    = lift . getParameter+  getBody         = lift getBody+  getMethod       = lift getMethod+  getPaths        = lift getPaths+  lookupMimeType  = lift . lookupMimeType+  setHeader nm    = lift . setHeader nm+  setResponseCode = lift . setResponseCode++instance Rest m => Rest (ReaderT r m) where+  getHeader       = lift . getHeader+  getParameter    = lift . getParameter+  getBody         = lift getBody+  getMethod       = lift getMethod+  getPaths        = lift getPaths+  lookupMimeType  = lift . lookupMimeType+  setHeader nm    = lift . setHeader nm+  setResponseCode = lift . setResponseCode++instance Rest m => Rest (StateT s m) where+  getHeader       = lift . getHeader+  getParameter    = lift . getParameter+  getBody         = lift getBody+  getMethod       = lift getMethod+  getPaths        = lift getPaths+  lookupMimeType  = lift . lookupMimeType+  setHeader nm    = lift . setHeader nm+  setResponseCode = lift . setResponseCode++instance (Monoid w, Rest m) => Rest (WriterT w m) where+  getHeader       = lift . getHeader+  getParameter    = lift . getParameter+  getBody         = lift getBody+  getMethod       = lift getMethod+  getPaths        = lift getPaths+  lookupMimeType  = lift . lookupMimeType+  setHeader nm    = lift . setHeader nm+  setResponseCode = lift . setResponseCode++instance Rest m => Rest (IdentityT m) where+  getHeader       = lift . getHeader+  getParameter    = lift . getParameter+  getBody         = lift getBody+  getMethod       = lift getMethod+  getPaths        = lift getPaths+  lookupMimeType  = lift . lookupMimeType+  setHeader nm    = lift . setHeader nm+  setResponseCode = lift . setResponseCode++instance Rest m => Rest (MaybeT m) where+  getHeader       = lift . getHeader+  getParameter    = lift . getParameter+  getBody         = lift getBody+  getMethod       = lift getMethod+  getPaths        = lift getPaths+  lookupMimeType  = lift . lookupMimeType+  setHeader nm    = lift . setHeader nm+  setResponseCode = lift . setResponseCode++writeResponse :: Rest m => RunnableHandler m -> m UTF8.ByteString+writeResponse (RunnableHandler run (GenHandler dict act _)) = do+  res <- runErrorT $ do+    let os = L.get D.outputs dict+    validator os+    inp <- fetchInputs dict+    output <- mapErrorT run (act inp)+    outputWriter os output+  case res of+    Left  er -> failureWriter (L.get D.errors dict) er+    Right r  -> return r++-------------------------------------------------------------------------------+-- Fetching the input resource.++fetchInputs :: Rest m => Dict h p j o e -> ErrorT (Reason e) m (Env h p j)+fetchInputs dict =+  do bs <- getBody+     ct <- parseContentType++     h <- HeaderError `mapE` headers    (L.get D.headers dict)+     p <- ParamError  `mapE` parameters (L.get D.params dict)+     let inputs = L.get D.inputs dict+     j <- InputError  `mapE`+            case inputs of+              None -> return ()+              _    ->+                case ct of+                  Just XmlFormat      -> parser XmlFormat     inputs bs+                  Just JsonFormat     -> parser JsonFormat    inputs bs+                  Just StringFormat   -> parser StringFormat  inputs bs+                  Just FileFormat     -> parser FileFormat    inputs bs+                  Just x              -> throwError (UnsupportedFormat (show x))+                  Nothing | B.null bs -> parser NoFormat inputs bs+                  Nothing             -> throwError (UnsupportedFormat "unknown")+     return (Env h p j)++parseContentType :: Rest m => m (Maybe Format)+parseContentType =+  do ct <- fromMaybe "" <$> getHeader "Content-Type"+     let segs  = concat (take 1 . splitOn ";" <$> splitOn "," ct)+         types = flip concatMap segs $ \ty ->+                   case splitOn "/" ty of+                     ["application", "xml"]          -> [XmlFormat]+                     ["application", "json"]         -> [JsonFormat]+                     ["text",        "xml"]          -> [XmlFormat]+                     ["text",        "json"]         -> [JsonFormat]+                     ["text",        "plain"]        -> [StringFormat]+                     ["application", "octet-stream"] -> [FileFormat]+                     ["application", _             ] -> [FileFormat]+                     ["image",       _             ] -> [FileFormat]+                     _                               -> []+     return (headMay types)++headers :: Rest m => Header h -> ErrorT DataError m h+headers NoHeader      = return ()+headers (Header xs h) = mapM getHeader xs >>= either throwError return . h++parameters :: Rest m => Param p -> ErrorT DataError m p+parameters NoParam      = return ()+parameters (Param xs p) = mapM (lift . getParameter) xs >>= either throwError return . p+parameters (TwoParams p1 p2) = (,) <$> parameters p1 <*> parameters p2++parser :: Monad m => Format -> Inputs j -> B.ByteString -> ErrorT DataError m j+parser NoFormat None       _ = return ()+parser f        None       _ = throwError (UnsupportedFormat (show f))+parser f        (Dicts ds) v = parserD f ds+  where+    parserD :: Monad m => Format -> [D.Input j] -> ErrorT DataError m j+    parserD XmlFormat     (XmlI     : _ ) = case eitherFromXML (UTF8.toString v) of+                                              Left err -> throwError (ParseError err)+                                              Right  r -> return r+    parserD XmlFormat     (XmlTextI : _ ) = return (decodeUtf8 v)+    parserD StringFormat  (ReadI    : _ ) = (throwError (ParseError "Read") `maybe` return) (readMay (UTF8.toString v))+    parserD JsonFormat    (JsonI    : _ ) = case eitherDecodeV v of+                                              Right a -> return a+                                              Left  e -> throwError (ParseError e)+    parserD StringFormat  (StringI  : _ ) = return (UTF8.toString v)+    parserD FileFormat    (FileI    : _ ) = return v+    parserD XmlFormat     (RawXmlI  : _ ) = return v+    parserD t             []              = throwError (UnsupportedFormat (show t))+    parserD t             (_        : xs) = parserD t xs++-------------------------------------------------------------------------------+-- Failure responses.++failureWriter :: Rest m => Errors e -> Reason e -> m UTF8.ByteString+failureWriter es err =+  do formats <- accept+     fromMaybeT (printFallback formats) $+       msum (  (tryPrint err                     es   <$> (formats ++ [XmlFormat]))+            ++ (tryPrint (fallbackError formats) None <$> formats                 )+            )+  where+    tryPrint :: forall m e. Rest m => Reason e -> Errors e -> Format -> MaybeT m UTF8.ByteString+    tryPrint e None JsonFormat = printError JsonFormat (toRespCode e) (encode e)+    tryPrint e None XmlFormat  = printError XmlFormat  (toRespCode e) (UTF8.fromString (toXML e))+    tryPrint _ None _          = mzero+    tryPrint e (Dicts ds) f = tryPrintD ds f+      where+        tryPrintD :: Rest m => [D.Error e] -> Format -> MaybeT m UTF8.ByteString+        tryPrintD (JsonE   : _ ) JsonFormat = printError JsonFormat (toRespCode e) (encode e)+        tryPrintD (XmlE    : _ ) XmlFormat  = printError XmlFormat  (toRespCode e) (UTF8.fromString (toXML e))+        tryPrintD (_       : xs) t          = tryPrintD xs t+        tryPrintD []             _          = mzero++    printError f cd x =+      do contentType f+         setResponseCode cd+         return x++    printFallback fs = printError XmlFormat (toRespCode (fallbackError fs)) (UTF8.fromString (toXML $ fallbackError fs))++    fallbackError :: [Format] -> Reason_+    fallbackError fs = OutputError (UnsupportedFormat $ intercalate "," $ map formatCT fs)++    formatCT v =+      case v of+        XmlFormat       -> "xml"+        JsonFormat      -> "json"+        StringFormat    -> "text/plain"+        FileFormat      -> "application/octet-stream"+        MultipartFormat -> "multipart/mixed"+        NoFormat        -> "any"++    fromMaybeT def = runMaybeT >=> maybe def return++    toRespCode e =+      case e of+        NotFound                          -> 404+        UnsupportedRoute                  -> 404+        UnsupportedMethod                 -> 404+        UnsupportedVersion                -> 404+        NotAllowed                        -> 403+        AuthenticationFailed              -> 401+        Busy                              -> 503+        Gone                              -> 410+        OutputError (UnsupportedFormat _) -> 406+        InputError  _                     -> 400+        OutputError _                     -> 500+        IdentError  _                     -> 400+        HeaderError _                     -> 400+        ParamError  _                     -> 400+        CustomReason (DomainReason r _)   -> r++-------------------------------------------------------------------------------+-- Printing the output resource.++contentType :: Rest m => Format -> m ()+contentType c = setHeader "Content-Type" $+  case c of+    JsonFormat -> "application/json; charset=UTF-8"+    XmlFormat  -> "application/xml; charset=UTF-8"+    _          -> "text/plain; charset=UTF-8"++validator :: forall v m e. Rest m => Outputs v -> ErrorT (Reason e) m ()+validator outputs = lift accept >>= \formats -> OutputError `mapE`+   (msum (try outputs <$> formats) <|> throwError (UnsupportedFormat (show formats)))++  where+    try :: Outputs v -> Format -> ErrorT DataError m ()+    try None NoFormat        = return ()+    try None XmlFormat       = return ()+    try None JsonFormat      = return ()+    try None StringFormat    = return ()+    try None MultipartFormat = return ()+    try None FileFormat      = throwError (UnsupportedFormat (show FileFormat))+    try (Dicts ds) f = tryD ds f+      where+        tryD (XmlO       : _ ) XmlFormat    = return ()+        tryD (RawXmlO    : _ ) XmlFormat    = return ()+        tryD (JsonO      : _ ) JsonFormat   = return ()+        tryD (StringO    : _ ) StringFormat = return ()+        tryD (FileO      : _ ) FileFormat   = return ()+        tryD (MultipartO : _ ) _            = return () -- Multipart is always ok, subparts can fail.+        tryD []                t            = throwError (UnsupportedFormat (show t))+        tryD (_          : xs) t            = tryD xs t++outputWriter :: forall v m e. Rest m => Outputs v -> v -> ErrorT (Reason e) m UTF8.ByteString+outputWriter outputs v = lift accept >>= \formats -> OutputError `mapE`+  (msum (try outputs <$> formats) <|> throwError (UnsupportedFormat (show formats)))++  where+    try :: Outputs v -> Format -> ErrorT DataError m UTF8.ByteString+    try None NoFormat        = contentType NoFormat >> ok ""+    try None XmlFormat       = contentType NoFormat >> ok "<done/>"+    try None JsonFormat      = contentType NoFormat >> ok "{}"+    try None StringFormat    = contentType NoFormat >> ok "done"+    try None FileFormat      = throwError (UnsupportedFormat (show FileFormat))+    try None MultipartFormat = contentType NoFormat >> ok ""+    try (Dicts ds) f = tryD ds f+      where+        tryD (XmlO       : _ ) XmlFormat    = contentType XmlFormat    >> ok (UTF8.fromString (toXML v))+        tryD (RawXmlO    : _ ) XmlFormat    = contentType XmlFormat    >> ok v+        tryD (JsonO      : _ ) JsonFormat   = contentType JsonFormat   >> ok (encode v)+        tryD (StringO    : _ ) StringFormat = contentType StringFormat >> ok (UTF8.fromString v)+        tryD (MultipartO : _ ) _            = outputMultipart v+        tryD (FileO      : _ ) FileFormat   = do mime <- fromMaybe "application/octet-stream" <$> lookupMimeType (map toLower (snd v))+                                                 setHeader "Content-Type" mime+                                                 setHeader "Cache-Control" "private, max-age=604800"+                                                 ok (fst v)+        tryD []                t            = throwError (UnsupportedFormat (show t))+        tryD (_          : xs) t            = tryD xs t+    ok r = setResponseCode 200 >> return r++outputMultipart :: Rest m => [BodyPart] -> m UTF8.ByteString+outputMultipart vs =+  do let boundary = show $ unsafePerformIO (randomIO :: IO UUID)+     setHeader "Content-Type" ("multipart/mixed; boundary=" ++ boundary)+     return $ showMultipartBody boundary (MultiPart vs)++accept :: Rest m => m [Format]+accept =+  do acceptHeader <- getHeader "Accept"+     ct <- parseContentType+     ty <- fromMaybe "" <$> getParameter "type"+     let fromQuery =+           case ty of+             "json" -> [JsonFormat]+             "xml"  -> [XmlFormat]+             _      -> []+         fromAccept = maybe (allFormats ct) (splitter ct) acceptHeader+     return (fromQuery ++ fromAccept)++  where+    allFormats ct = (maybe id (:) ct) [minBound .. maxBound]+    splitter ct hdr = nub (match ct =<< takeWhile (/= ';') . trim <$> splitOn "," hdr)++    match ct ty =+      case map trim <$> (splitOn "+" . trim <$> splitOn "/" ty) of+        [ ["*"]           , ["*"] ] -> allFormats ct+        [ ["*"]                   ] -> allFormats ct+        [ ["text"]        , xs    ] -> xs >>= txt+        [ ["application"] , xs    ] -> xs >>= app+        [ ["image"]       , xs    ] -> xs >>= img+        _                           -> []++    trim = reverse . dropWhile isSpace . reverse . dropWhile isSpace++    txt "*"     = [XmlFormat, JsonFormat, StringFormat]+    txt "json"  = [JsonFormat]+    txt "xml"   = [XmlFormat]+    txt "plain" = [StringFormat]+    txt _       = []+    app "*"     = [XmlFormat, JsonFormat]+    app "xml"   = [XmlFormat]+    app "json"  = [JsonFormat]+    app _       = []+    img _       = [FileFormat]

@@ -0,0 +1,80 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+module Rest.Driver.RestM+  ( RestM+  , runRestM+  , runRestM_+  , RestInput (..)+  , emptyInput+  , RestOutput (..)+  ) where++import Control.Applicative+import Control.Monad.Reader+import Control.Monad.Writer+import Data.Map (Map)++import qualified Data.Map                  as Map+import qualified Data.ByteString.Lazy.UTF8 as UTF8++import Rest.Driver.Perform (Rest)+import qualified Rest.Driver.Types   as Rest+import qualified Rest.Driver.Perform as Rest++data RestInput = RestInput+  { headers      :: Map String String+  , parameters   :: Map String String+  , body         :: UTF8.ByteString+  , method       :: Rest.Method+  , paths        :: [String]+  , mimeTypes    :: Map String String+  }++emptyInput :: RestInput+emptyInput = RestInput+  { headers    = Map.empty+  , parameters = Map.empty+  , body       = mempty+  , method     = Rest.GET+  , paths      = []+  , mimeTypes  = Map.empty+  }++data RestOutput = RestOutput+  { headersSet   :: Map String String+  , responseCode :: Maybe Int+  } deriving Show++instance Monoid RestOutput where+  mempty = RestOutput { headersSet = Map.empty, responseCode = Nothing }+  o1 `mappend` o2 = RestOutput+    { headersSet   = headersSet o2 `Map.union` headersSet o1+    , responseCode = responseCode o2 <|> responseCode o1+    }++outputHeader :: String -> String -> RestOutput+outputHeader h v = mempty { headersSet = Map.singleton h v }++outputCode :: Int -> RestOutput+outputCode cd = mempty { responseCode = Just cd }++newtype RestM m a = RestM { unRestM :: ReaderT RestInput (WriterT RestOutput m) a }+  deriving (Functor, Applicative, Monad)++instance MonadTrans RestM where+  lift = RestM . lift . lift++runRestM :: RestInput -> RestM m a -> m (a, RestOutput)+runRestM i = runWriterT . flip runReaderT i . unRestM++runRestM_ :: Functor m => RestInput -> RestM m a -> m a+runRestM_ i = fmap fst . runRestM i++instance (Functor m, Applicative m, Monad m) => Rest (RestM m) where+  getHeader    h     = RestM $ asks (Map.lookup h . headers   )+  getParameter p     = RestM $ asks (Map.lookup p . parameters)+  getBody            = RestM $ asks body+  getMethod          = RestM $ asks method+  getPaths           = RestM $ asks paths+  lookupMimeType t   = RestM $ asks (Map.lookup t . mimeTypes)+  setHeader h v      = RestM $ tell (outputHeader h v)+  setResponseCode cd = RestM $ tell (outputCode cd)

@@ -0,0 +1,347 @@+{-# LANGUAGE ExistentialQuantification+           , GeneralizedNewtypeDeriving+           , RankNTypes+           , NamedFieldPuns+           , FlexibleContexts+           , StandaloneDeriving+           , GADTs+           , ScopedTypeVariables+           , DeriveDataTypeable+           , TupleSections+           #-}+module Rest.Driver.Routing where++import Prelude hiding (id, (.))++import Control.Applicative+import Control.Arrow+import Control.Category+import Control.Error.Util+import Data.List.Split+import Control.Monad.Error+import Control.Monad.Identity+import Control.Monad.Reader+import Control.Monad.State (StateT, evalStateT, MonadState)+import Control.Monad.Trans.Either+import Control.Monad.Trans.Maybe+import Data.ByteString (ByteString)+import Network.CGI.Multipart (BodyPart (..))+import Network.CGI.Protocol  (HeaderName (..))+import Safe+import qualified Control.Monad.State       as State+import qualified Data.ByteString.UTF8      as UTF8+import qualified Data.ByteString.Lazy.UTF8 as LUTF8+import qualified Data.Label.Total          as L+import qualified Data.Map                  as Map++import Network.URI.Encode (decode)+import Rest.Api (Some1(..))+import Rest.Container+import Rest.Dictionary+import Rest.Error+import Rest.Handler (ListHandler, Handler, GenHandler (..), Env (..), range, mkInputHandler, Range (..))+import Rest.Types.Container.Resource (Resource, Resources (..))+import qualified Rest.Types.Container.Resource as R+import qualified Rest.Api                      as Rest+import qualified Rest.Resource                 as Rest+import qualified Rest.Schema                   as Rest++import Rest.Driver.Types+import Rest.Driver.Perform (writeResponse, failureWriter)+import Rest.Driver.RestM (runRestM)++import qualified Rest.Driver.RestM as Rest++type Uri = ByteString+type UriParts = [String]++apiError :: (MonadError (Reason e) m) => Reason e -> m a+apiError = throwError++newtype Router a =+  Router { unRouter :: ReaderT Method (StateT UriParts (EitherT Reason_ Identity)) a }+  deriving ( Functor+           , Applicative+           , Monad+           , MonadReader Method+           , MonadState UriParts+           , MonadError Reason_+           )++runRouter :: Method -> UriParts -> Router (RunnableHandler m) -> Either Reason_ (RunnableHandler m)+runRouter method uri = runIdentity+                     . runEitherT+                     . flip evalStateT uri+                     . flip runReaderT method+                     . unRouter++route :: Method -> UriParts -> Rest.Api m -> Either Reason_ (RunnableHandler m)+route method uri api = runRouter method uri $+  do versionStr <- popSegment+     case versionStr `Rest.lookupVersion` api of+          Just (Some1 router) -> routeRoot router+          _                   -> apiError UnsupportedVersion++routeRoot :: Rest.Router m s -> Router (RunnableHandler m)+routeRoot router@(Rest.Embed resource _) = do+  routeName (Rest.name resource)+  fromMaybeT (routeRouter router) (routeMultiGet router)++routeMultiGet :: Rest.Router m s -> MaybeT Router (RunnableHandler m)+routeMultiGet root@(Rest.Embed Rest.Resource{} _) =+  do guardNullPath+     guardMethod GET+     return (RunnableHandler id (mkMultiGetHandler root))++routeRouter :: Rest.Router m s -> Router (RunnableHandler m)+routeRouter (Rest.Embed resource@(Rest.Resource { Rest.schema }) subRouters) =+  case schema of+    (Rest.Schema mToplevel step) -> maybe (apiError UnsupportedRoute) return =<< runMaybeT+       (  routeToplevel resource subRouters mToplevel+      <|> routeCreate resource+      <|> lift (routeStep resource subRouters step)+       )++routeToplevel :: Rest.Resource m s sid mid aid+              -> [Some1 (Rest.Router s)]+              -> Maybe (Rest.Cardinality sid mid)+              -> MaybeT Router (RunnableHandler m)+routeToplevel resource@(Rest.Resource { Rest.list }) subRouters mToplevel =+  hoistMaybe mToplevel >>= \toplevel ->+  case toplevel of+    Rest.Single sid -> lift $ withSubresource sid resource subRouters+    Rest.Many   mid ->+      do guardNullPath+         guardMethod GET+         lift $ routeListHandler (list mid)++routeCreate :: Rest.Resource m s sid mid aid -> MaybeT Router (RunnableHandler m)+routeCreate (Rest.Resource { Rest.create }) = guardNullPath >> guardMethod POST >>+  maybe (apiError UnsupportedRoute) (return . RunnableHandler id) create++routeStep :: Rest.Resource m s sid mid aid+          -> [Some1 (Rest.Router s)]+          -> Rest.Step sid mid aid+          -> Router (RunnableHandler m)+routeStep resource subRouters step =+  case step of+    Rest.Named ns -> popSegment >>= \seg ->+      case lookup seg ns of+        Nothing -> apiError UnsupportedRoute+        Just h  -> routeNamed resource subRouters h+    Rest.Unnamed h -> routeUnnamed resource subRouters h++routeNamed :: Rest.Resource m s sid mid aid+           -> [Some1 (Rest.Router s)]+           -> Rest.Endpoint sid mid aid+           -> Router (RunnableHandler m)+routeNamed resource@(Rest.Resource { Rest.list, Rest.statics }) subRouters h =+  case h of+    Left aid -> noRestPath >> hasMethod POST >> return (RunnableHandler id (statics aid))+    Right (Rest.Single getter) -> routeGetter getter resource subRouters+    Right (Rest.Many   getter) -> routeListGetter getter list++routeUnnamed :: Rest.Resource m s sid mid aid+             -> [Some1 (Rest.Router s)]+             -> Rest.Cardinality (Rest.Id sid) (Rest.Id mid)+             -> Router (RunnableHandler m)+routeUnnamed resource@(Rest.Resource { Rest.list }) subRouters cardinality =+  case cardinality of+    Rest.Single sBy -> withSegment (multiPut resource sBy) $ \seg ->+      parseIdent sBy seg >>= \sid -> withSubresource sid resource subRouters+    Rest.Many   mBy ->+      do seg <- popSegment+         mid <- parseIdent mBy seg+         noRestPath+         hasMethod GET+         routeListHandler (list mid)++routeGetter :: Rest.Getter sid+            -> Rest.Resource m s sid mid aid+            -> [Some1 (Rest.Router s)]+            -> Router (RunnableHandler m)+routeGetter getter resource subRouters =+  case getter of+    Rest.Singleton sid -> getOrDeep sid+    Rest.By        sBy -> withSegment (multiPut resource sBy) $ \seg ->+                            parseIdent sBy seg >>= getOrDeep+  where+    getOrDeep sid = withSubresource sid resource subRouters++multiPut :: Rest.Resource m s sid mid aid -> Rest.Id sid -> Router (RunnableHandler m)+multiPut (Rest.Resource { Rest.update, Rest.enter }) sBy =+  do hasMethod PUT+     maybe (apiError UnsupportedRoute) return $+       do updateH    <- update+          putHandler <- mkMultiPutHandler sBy enter updateH+          return (RunnableHandler id putHandler)++routeListGetter :: Monad m+                => Rest.Getter mid+                -> (mid -> ListHandler m)+                -> Router (RunnableHandler m)+routeListGetter getter list = hasMethod GET >>+  case getter of+    Rest.Singleton mid -> noRestPath >> routeListHandler (list mid)+    Rest.By        mBy ->+      do seg <- popSegment+         mid <- parseIdent mBy seg+         noRestPath+         routeListHandler (list mid)++withSubresource :: sid+                -> Rest.Resource m s sid mid aid+                -> [Some1 (Rest.Router s)]+                -> Router (RunnableHandler m)+withSubresource sid resource@(Rest.Resource { Rest.enter, Rest.selects, Rest.actions }) subRouters =+  withSegment (routeSingle sid resource) $ \seg ->+  case lookup seg selects of+    Just select -> noRestPath >> hasMethod GET >> return (RunnableHandler (enter sid) select)+    Nothing -> case lookup seg actions of+      Just action -> noRestPath >> hasMethod POST >> return (RunnableHandler (enter sid) action)+      Nothing ->+        case lookupRouter seg subRouters of+          Just (Some1 subRouter) -> do+            (RunnableHandler subRun subHandler) <- routeRouter subRouter+            return (RunnableHandler (enter sid . subRun) subHandler)+          Nothing -> apiError UnsupportedRoute++routeSingle :: sid -> Rest.Resource m s sid mid aid -> Router (RunnableHandler m)+routeSingle sid (Rest.Resource { Rest.enter, Rest.get, Rest.update, Rest.remove }) =+  ask >>= \method ->+  case method of+    GET    -> handleOrNotFound get+    PUT    -> handleOrNotFound update+    DELETE -> handleOrNotFound remove+    _      -> apiError UnsupportedMethod+  where+    handleOrNotFound = maybe (apiError UnsupportedRoute) (return . RunnableHandler (enter sid))++routeName :: String -> Router ()+routeName ident = when (not . null $ ident) $+  do identStr <- popSegment+     when (identStr /= ident) $+       apiError UnsupportedRoute++routeListHandler :: Monad m => ListHandler m -> Router (RunnableHandler m)+routeListHandler list =+      maybe (apiError UnsupportedRoute)+            (return . RunnableHandler id)+            (mkListHandler list)++lookupRouter :: String -> [Some1 (Rest.Router s)] -> Maybe (Some1 (Rest.Router s))+lookupRouter _    [] = Nothing+lookupRouter name (Some1 router@(Rest.Embed resource _) : routers)+   =  (guard (Rest.name resource == name) >> return (Some1 router))+  <|> lookupRouter name routers++parseIdent :: MonadError (Reason e) m => Rest.Id id -> String -> m id+parseIdent (Rest.Id StringId byF) seg = return (byF seg)+parseIdent (Rest.Id ReadId   byF) seg =+  case readMay seg of+    Nothing  -> throwError (IdentError (ParseError $ "Failed to parse " ++ seg))+    Just sid -> return (byF sid)++splitUri :: Uri -> UriParts+splitUri = splitUriString . UTF8.toString++splitUriString :: String -> UriParts+splitUriString = filter (/= "") . map decode . splitOn "/"++popSegment :: Router String+popSegment =+  do uriParts <- State.get+     case uriParts of+       []      -> apiError UnsupportedRoute+       (hd:tl) -> do+         State.put tl+         return hd++withSegment :: Router a -> (String -> Router a) -> Router a+withSegment noSeg withSeg =+  do uriParts <- State.get+     case uriParts of+       [] -> noSeg+       (hd:tl) -> do+         State.put tl+         withSeg hd++noRestPath :: Router ()+noRestPath =+  do uriParts <- State.get+     unless (null uriParts) $+       apiError UnsupportedRoute++guardNullPath :: (MonadPlus m, MonadState UriParts m) => m ()+guardNullPath = State.get >>= guard . null++hasMethod :: Method -> Router ()+hasMethod wantedMethod = ask >>= \method ->+  if method == wantedMethod+  then return ()+  else apiError UnsupportedMethod++guardMethod :: (MonadPlus m, MonadReader Method m) => Method -> m ()+guardMethod method = ask >>= guard . (== method)++mkListHandler :: Monad m => ListHandler m -> Maybe (Handler m)+mkListHandler (GenHandler dict act sec) =+  do newDict <- L.traverse outputs listO . addPar range $ dict+     return $ GenHandler newDict (mkListAction act) sec++mkListAction :: Monad m+            => (Env h p i -> ErrorT (Reason e) m [a])+            -> Env h (Range, p) i+            -> ErrorT (Reason e) m (List a)+mkListAction act (Env h (Range f c, p) i) = do+  xs <- act (Env h p i)+  return (List f (min c (length xs)) (take c xs))++mkMultiPutHandler :: Monad m => Rest.Id id -> (id -> Run s m) -> Handler s -> Maybe (Handler m)+mkMultiPutHandler sBy run (GenHandler dict act sec) = GenHandler <$> mNewDict <*> pure newAct <*> pure sec+  where+    newErrDict = L.modify errors reasonE dict+    mNewDict =  L.traverse inputs mappingI+            <=< L.traverse outputs (mappingO <=< statusO (L.get errors newErrDict))+             $  newErrDict+    newAct (Env hs ps (StringMap vs)) =+      do bs <- lift $ forM vs $ \(k, v) -> runErrorT $+           do i <- parseIdent sBy k+              mapErrorT (run i) (act (Env hs ps v))+         return (StringMap (zipWith (\(k, _) b -> (k, eitherToStatus b)) vs bs))++mkMultiGetHandler :: forall m s. (Applicative m, Monad m) => Rest.Router m s -> Handler m+mkMultiGetHandler root = mkInputHandler (xmlJsonI . someI . multipartO) $ \(Resources rs) -> multiGetHandler rs+  where+    multiGetHandler rs = lift $+      do mapM (runResource root) rs++runResource :: forall m s. (Applicative m, Monad m) => Rest.Router m s -> Resource -> m BodyPart+runResource root res+  = fmap (uncurry mkBodyPart)+  . runRestM (toRestInput res)+  . either (failureWriter None) (writeResponse . mapHandler lift)+  . routeResource+  $ R.uri res+  where+    routeResource :: String -> Either Reason_ (RunnableHandler m)+    routeResource uri = runRouter GET (splitUriString uri) (routeRoot root)++    toRestInput r = Rest.emptyInput+      { Rest.headers    = Map.map R.unValue . fromStringMap . R.headers    $ r+      , Rest.parameters = Map.map R.unValue . fromStringMap . R.parameters $ r+      , Rest.body       = LUTF8.fromString (R.input r)+      , Rest.paths      = splitUriString (R.uri r)+      }++    mkHeaders = map (first HeaderName) . Map.toList++    mkBodyPart bdy restOutput =+      let hdrs = (HeaderName "X-Response-Code", maybe "200" show (Rest.responseCode restOutput))+               : mkHeaders (Rest.headersSet restOutput)+      in BodyPart hdrs bdy++-- * Utilities++fromMaybeT :: Monad m => m a -> MaybeT m a -> m a+fromMaybeT def act = runMaybeT act >>= maybe def return

@@ -0,0 +1,16 @@+{-# LANGUAGE ExistentialQuantification, RankNTypes #-}+module Rest.Driver.Types where++import Rest.Handler (Handler)++type Run m n = forall a. m a -> n a++data RunnableHandler n = forall m. RunnableHandler+  (Run m n)   -- Runner to the base monad.+  (Handler m) -- Actual handler to run.++mapHandler :: Run m n -> RunnableHandler m -> RunnableHandler n+mapHandler run (RunnableHandler run' h) = RunnableHandler (run . run') h++data Method = GET | PUT | POST | DELETE | Unknown String+  deriving (Show, Eq)

@@ -0,0 +1,47 @@+{-# LANGUAGE+    TemplateHaskell+  , EmptyDataDecls+  , TypeFamilies+  , GADTs+  , ScopedTypeVariables+  , StandaloneDeriving+  , DeriveDataTypeable+  #-}+-- | Error types that can be returned by handlers, as well as some+-- utilities for manipulating these errors.+module Rest.Error+  ( module Rest.Types.Error+  , mapE+  , orThrow+  , orThrowWith+  , eitherToStatus+  , domainReason+  ) where++import Control.Applicative+import Control.Monad.Error++import Rest.Types.Error++-- Error utilities.++infixl 8 `mapE`++mapE :: (Applicative m, Monad m) => (e -> e') -> ErrorT e m a -> ErrorT e' m a+mapE f = mapErrorT (either (Left . f) Right <$>)++orThrow :: MonadError e m => m (Maybe b) -> e -> m b+orThrow a e = a >>= throwError e `maybe` return++orThrowWith :: MonadError a m => m (Either e b) -> (e -> a) -> m b+orThrowWith a f = a >>= (throwError . f) `either` return++eitherToStatus :: Either a b -> Status a b+eitherToStatus (Left  e) = Failure e+eitherToStatus (Right e) = Success e++-- | Wrap your custom error type in a 'Reason'. The first argument is+-- a function for converting your error to an HTTP status code.++domainReason :: (a -> Int) -> a -> Reason a+domainReason f x = CustomReason (DomainReason (f x) x)

@@ -0,0 +1,172 @@+{-# LANGUAGE GADTs, KindSignatures, TupleSections, DeriveDataTypeable, TypeFamilies #-}+-- | Handlers for endpoints in a 'Resource'.+module Rest.Handler+  ( -- * Single handlers.+    mkHandler+  , mkInputHandler+  , mkConstHandler+  , mkIdHandler++    -- * Listings.+  , mkListing+  , mkOrderedListing+    -- ** Parameter parsers for listings.+  , Range (..)+  , range+  , orderedRange++    -- * Generic handlers and core data types.+  , Env (..)+  , GenHandler (..)+  , mkGenHandler+  , Apply+  , Handler+  , ListHandler++    -- * Convenience functions.+  , secureHandler+  ) where++import Control.Arrow+import Control.Applicative hiding (empty)+import Control.Monad.Error+import Control.Monad.Identity+import Control.Monad.Reader+import Safe++import Rest.Dictionary+import Rest.Error++-------------------------------------------------------------------------------++-- | An environment of inputs passed to a handler. Contains+-- information from the 'header's, the 'param'eters and the body+-- 'input'.++data Env h p i = Env+  { header :: h+  , param  :: p+  , input  :: i+  }++-- | A handler for some endpoint. The input and output types are+-- specified by the 'dictionary', which can be created using the+-- combinators from "Rest.Dictionary.Combinators". The inputs+-- (headers, parameters and body) are passed as an 'Env' to the+-- 'handler'. This handler runs in monad @m@, combined with the+-- ability to throw errors. The result is either the output value, or+-- a list of them for list handlers.+-- If the 'secure' flag is set, this suggests to clients that the+-- resource should only be served over https. It has no effect when+-- running the API.++data GenHandler m f where+  GenHandler ::+    { dictionary :: Dict h p i o e+    , handler    :: Env h p i -> ErrorT (Reason e) m (Apply f o)+    , secure     :: Bool+    } -> GenHandler m f++-- | Construct a 'GenHandler' using a 'Modifier' instead of a 'Dict'.+-- The 'secure' flag will be 'False'.++mkGenHandler :: Monad m => Modifier h p i o e -> (Env h p i -> ErrorT (Reason e) m (Apply f o)) -> GenHandler m f+mkGenHandler d a = GenHandler (d empty) a False++-- | Apply a Functor @f@ to a type @a@. In general will result in @f+-- a@, except if @f@ is 'Identity', in which case it will result in+-- @a@. This prevents a lot of 'Identity' wrapping/unwrapping.++type family Apply (f :: * -> *) a :: *+type instance Apply Identity a = a+type instance Apply []       a = [a]++-- | A 'Handler' returning a single item.+type Handler     m = GenHandler m Identity+-- | A 'Handler' returning a list of items.+type ListHandler m = GenHandler m []++-- | Set 'secure' to 'True'.++secureHandler :: Handler m -> Handler m+secureHandler h = h { secure = True }++-- | Data type for representing the requested range in list handlers.++data Range = Range { offset :: Int, count :: Int }++-- | Smart constructor for creating a list handler.++mkListing+  :: Monad m+  => Modifier () () () o e+  -> (Range -> ErrorT (Reason e) m [o])+  -> ListHandler m+mkListing d a = mkGenHandler (mkPar range . d) (a . param)++-- | Dictionary for taking 'Range' parameters. Allows two query+-- parameters, @offset@ and @count@. If not passed, the defaults are 0+-- and 100. The maximum range that can be passed is 1000.++range :: Param Range+range = Param ["offset", "count"] $ \xs ->+  maybe (Left (ParseError "range"))+        (Right . normalize)+    $ case xs of+        [Just o, Just c] -> Range         <$> readMay o <*> readMay c+        [_     , Just c] -> Range 0       <$> readMay c+        [Just o, _     ] -> (`Range` 100) <$> readMay o+        _                -> Just $ Range 0 100+  where normalize r = Range { offset = max 0 . offset $ r+                            , count  = min 1000 . max 0 . count $ r+                            }++-- | Create a list handler that accepts ordering information.++mkOrderedListing+  :: Monad m+  => Modifier () () () o e+  -> ((Range, Maybe String, Maybe String) -> ErrorT (Reason e) m [o])+  -> ListHandler m+mkOrderedListing d a = mkGenHandler (mkPar orderedRange . d) (a . param)++-- | Dictionary for taking ordering information. In addition to the+-- parameters accepted by 'range', this accepts @order@ and+-- @direction@.+orderedRange :: Param (Range, Maybe String, Maybe String)+orderedRange = Param ["offset", "count", "order", "direction"] $ \xs ->+  case xs of+    [mo, mc, mor, md] ->+      maybe (Left (ParseError "range"))+            (Right . (\(o, c) -> (Range o c, mor, md)) . normalize)+        $ case (mo, mc) of+            (Just o, Just c) -> (,)    <$> readMay o <*> readMay c+            (_     , Just c) -> (0,)   <$> readMay c+            (Just o, _     ) -> (,100) <$> readMay o+            _                -> Just (0, 100)+    _ -> error "Internal error in orderedRange rest parameters"+  where normalize = (max 0 *** (min 1000 . max 0))++-- | Create a handler for a single resource. Takes the entire+-- environmend as input.++mkHandler :: Monad m => Modifier h p i o e -> (Env h p i -> ErrorT (Reason e) m o) -> Handler m+mkHandler = mkGenHandler++-- | Create a handler for a single resource. Takes only the body+-- information as input.++mkInputHandler :: Monad m => Modifier () () i o e -> (i -> ErrorT (Reason e) m o) -> Handler m+mkInputHandler d a = mkHandler d (a . input)++-- | Create a handler for a single resource. Doesn't take any input.++mkConstHandler :: Monad m => Modifier () () () o e -> ErrorT (Reason e) m o -> Handler m+mkConstHandler d a = mkHandler d (const a)++-- | Create a handler for a single resource. Take body information and+-- the resource identifier as input. The monad @m@ should be a+-- 'Reader'-like type containing the idenfier.++mkIdHandler :: MonadReader id m => Modifier h p i o e -> (i -> id -> ErrorT (Reason e) m o) -> Handler m+mkIdHandler d a = mkHandler d (\env -> ask >>= a (input env))

@@ -0,0 +1,31 @@+-- | Module facilitating informative inspection of datatypes.++{-# LANGUAGE+    FlexibleInstances+  , TypeSynonymInstances+  #-}+module Rest.Info where++import Data.Text (Text)+import Data.Typeable++-- | Type class representing information about the read/show function on a data+-- type.++class Typeable a => Info a where+  describe :: proxy a -> String+  example  :: proxy a -> String+  example _ = ""++instance Info String where+  describe _ = "string"++instance Info Text where+  describe _ = "string"++instance Info Int where+  describe _ = "integer"++instance Info Integer where+  describe _ = "integer"+

@@ -0,0 +1,100 @@+{-# LANGUAGE+    TemplateHaskell+  , MultiParamTypeClasses+  , FlexibleInstances+  , FlexibleContexts+  , TypeSynonymInstances+  , RankNTypes+  , KindSignatures+  , GADTs+  , NamedFieldPuns+  #-}+-- | A 'Resource' type for representing a REST resource, as well as+-- smart constructors for empty resources which can them be filled in+-- using record updates.+module Rest.Resource where++import Control.Applicative (Applicative)+import Control.Monad.Reader++import Rest.Handler+import Rest.Schema (Schema (..), Step (..))++-- * The @Resource@ type.++-- | The 'Resource' data type represents a single resource in a REST+-- API. Handlers run in a monad @m@, while things below this resource+-- run in @s@. The identifiers @sid@, @mid@ and @aid@ identify a+-- single item, a listing and an action.++data Resource m s sid mid aid where+  Resource :: (Applicative m, Monad m, Applicative s, Monad s) =>+    { name        :: String                      -- ^ The name for this resource, used as a path segment in routing.+    , description :: String                      -- ^ A description of the resource, used for documentation.+    , schema      :: Schema sid mid aid          -- ^ The schema for routing and identification.+    , private     :: Bool                        -- ^ Private resources are not documented, but they are exposed.+    , enter       :: forall b. sid -> s b -> m b -- ^ How to run a subresource given an id.++    , list        :: mid -> ListHandler m        -- ^ List handler, both toplevel and deeper (search).++    , statics     :: aid -> Handler m            -- ^ Static actions, e.g. signin.++    , get         :: Maybe (Handler s)           -- ^ Get a single resource identified by id.+    , update      :: Maybe (Handler s)           -- ^ Update a single resource identified by id.+    , remove      :: Maybe (Handler s)           -- ^ Delete a single resource identified by id.+    , create      :: Maybe (Handler m)           -- ^ Create a single resource, generating a new id.+    , actions     :: [(String, Handler s)]       -- ^ Actions performed on a single resource.+    , selects     :: [(String, Handler s)]       -- ^ Properties of a single resource.+    } -> Resource m s sid mid aid++-- * Smart constructors for empty resources.++-- | Create an empty resource given an 'enter' function. It has no+-- name, so if you wish to route to this resource, you should set one.++mkResource :: (Applicative m, Monad m, Applicative s, Monad s) => (forall b. sid -> s b -> m b) -> Resource m s sid Void Void+mkResource e = Resource+  { name           = ""+  , description    = ""+  , schema         = Schema Nothing (Named [])+  , private        = False+  , enter          = e++  , list           = magic++  , statics        = magic++  , get            = Nothing+  , update         = Nothing+  , remove         = Nothing+  , create         = Nothing+  , actions        = []+  , selects        = []+  }++-- | Make a resource that doesn't add any information for+-- subresources (i.e. 'enter' is set to 'id').++mkResourceId :: (Applicative m, Monad m) => Resource m m sid Void Void+mkResourceId = mkResource (const id)++-- | Make a resource that provides the single resource identifier to+-- its subresources.++mkResourceReader :: (Applicative m, Monad m) => Resource m (ReaderT sid m) sid Void Void+mkResourceReader = mkResourceReaderWith id++-- | Make a resource that provides the single resource identifier to+-- its subresources, by giving a convertion function to a 'ReaderT'.+-- If @s@ is a newtype around 'ReaderT', for example, the function+-- should unwrap the newtype.++mkResourceReaderWith :: (Applicative m, Monad m, Applicative s, Monad s) => (forall b. s b -> ReaderT sid m b) -> Resource m s sid Void Void+mkResourceReaderWith f = mkResource (\a -> flip runReaderT a . f)++-- * The @Void@ type.++-- | The 'Void' type is used as the identifier for resources that+-- can't be routed to. It contains no values apart from bottom.++newtype Void = Void { magic :: forall a. a }

@@ -0,0 +1,24 @@+{-# LANGUAGE RankNTypes #-}+module Rest.Run+  ( apiToHandler+  , apiToHandler'+  ) where++import qualified Data.ByteString.Lazy.UTF8 as UTF8++import Rest.Api (Api)+import Rest.Dictionary ( Dicts (..) )+import Rest.Driver.Perform+import Rest.Driver.Routing+import Rest.Driver.Types++apiToHandler :: Rest m => Api m -> m UTF8.ByteString+apiToHandler = apiToHandler' id++apiToHandler' :: Rest n => Run m n -> Api m -> n UTF8.ByteString+apiToHandler' run api = do+  method <- getMethod+  paths  <- getPaths+  case route method paths api of+    Left  e -> failureWriter None e+    Right h -> writeResponse (mapHandler run h)

@@ -0,0 +1,181 @@+{-# LANGUAGE ExistentialQuantification #-}+-- | This module contains data types and combinators for defining a+-- 'Schema' for your 'Resource'. A 'Schema' has three type parameters,+-- specifying the identifiers for a single resource, a listing, and a+-- top-level action. After routing, these identifiers will be passed+-- to the 'Handler'.+module Rest.Schema+  ( -- * A set of combinators for creating schemas.++    -- ** Top level+    withListing+  , noListing+  , singleton+    -- ** Named endpoints+  , named+  , action+  , single+  , singleBy+  , singleRead+  , listing+  , listingBy+  , listingRead+    -- ** Unnamed endpoints+  , unnamedSingle+  , unnamedSingleRead+  , unnamedListing+  , unnamedListingRead++    -- * The core schema data types.++  , Schema (..)+  , Step (..)+  , Cardinality (..)+  , Getter (..)+  , Id (..)+  , Endpoint+  ) where++import Rest.Dictionary (Ident (..))+import Rest.Info (Info)++-- * A set of combinators for creating schemas.++-- ** Top level++-- | A schema with a top level listing.++withListing :: mid -> Step sid mid aid -> Schema sid mid aid+withListing mid = Schema (Just (Many mid))++-- | A schema with no top level listing.++noListing :: Step sid mid aid -> Schema sid mid aid+noListing = Schema Nothing++-- | A schema with a singleton at the top level.++singleton :: sid -> Step sid mid aid -> Schema sid mid aid+singleton sid = Schema (Just (Single sid))++-- ** Named endpoints++-- | A list of named endpoints.++named :: [(String, Endpoint sid mid aid)] -> Step sid mid aid+named = Named++-- | An action endpoint.++action :: aid -> Endpoint sid mid aid+action = Left++-- | A singleton resource endpoint.++single :: sid -> Endpoint sid mid aid+single = Right . Single . Singleton++-- | A single resource endpoint with a string identifier.++singleBy :: (String -> sid) -> Endpoint sid mid aid+singleBy = singleIdent StringId++-- | A single resource endpoint with an identifier that can be read.++singleRead :: (Show a, Read a, Info a) => (a -> sid) -> Endpoint sid mid aid+singleRead = singleIdent ReadId++-- | A single resource identified as specified by the 'Ident'.++singleIdent :: Ident a -> (a -> sid) -> Endpoint sid mid aid+singleIdent ident = Right . Single . By . Id ident++-- | A listing endpoint.++listing :: mid -> Endpoint sid mid aid+listing = Right . Many . Singleton++-- | A listing endpoint with a string identifier.++listingBy :: (String -> mid) -> Endpoint sid mid aid+listingBy = listingIdent StringId++-- | A listing with an identifier that can be read.++listingRead :: (Show a, Read a, Info a) => (a -> mid) -> Endpoint sid mid aid+listingRead = listingIdent ReadId++-- | A listing identified as specified by the 'Ident'.+listingIdent :: Ident a -> (a -> mid) -> Endpoint sid mid aid+listingIdent ident = Right . Many . By . Id ident++-- ** Unnamed endpoints++-- | An unnamed single resource with a string identifier.++unnamedSingle :: (String -> sid) -> Step sid mid aid+unnamedSingle = unnamedSingleIdent StringId++-- | An unnamed single resource with an identifier that can be read.++unnamedSingleRead :: (Show a, Read a, Info a) => (a -> sid) -> Step sid mid aid+unnamedSingleRead = unnamedSingleIdent ReadId++-- | An unnamed single resource identified as specified by the+-- 'Ident'.++unnamedSingleIdent :: Ident a -> (a -> sid) -> Step sid mid aid+unnamedSingleIdent ident = Unnamed . Single . Id ident++-- | An unnamed listing with a string identifier.++unnamedListing :: (String -> mid) -> Step sid mid aid+unnamedListing = unnamedListingIdent StringId++-- | An unnamed listing with an identifier that can be read.+unnamedListingRead :: (Show a, Read a, Info a) => (a -> mid) -> Step sid mid aid+unnamedListingRead = unnamedListingIdent ReadId++-- | An unnamed listing identified as specified by the 'Ident'.++unnamedListingIdent :: Ident a -> (a -> mid) -> Step sid mid aid+unnamedListingIdent ident = Unnamed . Many . Id ident++-- * The core schema data types.++-- | A 'Schema' describes how (part of the) route to a resource looks,+-- and returns an identifier for a single resource ('sid'), many+-- resources ('mid') or an action ('aid').+-- The first argument specifies the top level resource (no path+-- segments). The second specifies a what happens at the first step in+-- the path.++data Schema sid mid aid = Schema (Maybe (Cardinality sid mid)) (Step sid mid aid)++-- | A step in the routing of a resource. A part of the uri either+-- identifies a 'Named' resource, or an 'Unnamed' resource. Named+-- resources can be actions ('Left') or one or many singletons or+-- by's.++data Step sid mid aid = Named   [(String, Endpoint sid mid aid)]+                      | Unnamed (Cardinality (Id sid) (Id mid))++-- | Specifies if we're identifying a single resource, or many (a+-- listing).+data Cardinality s m = Single s+                     | Many   m++-- | A 'Getter' can either be a 'Singleton' (there is only one) or it+-- can be identified 'By' an 'Id'entifier.++data Getter id = Singleton id | By (Id id)++-- | An identification of an item in a resource. It contains a+-- dictionary describing how to identify the resource, and a function+-- for this identification type to an @id@.++data Id id = forall a. Id (Ident a) (a -> id)++-- | A named endpoint: an action, a single item of many items.++type Endpoint sid mid aid = Either aid (Cardinality (Getter sid) (Getter mid))

@@ -0,0 +1,206 @@+{-# LANGUAGE ScopedTypeVariables, OverloadedStrings #-}++import Control.Applicative+import Control.Monad+import Control.Monad.Reader+import Data.Monoid+import Test.Framework (defaultMain)+import Test.Framework.Providers.HUnit (testCase)+import Test.HUnit (Assertion, assertFailure, assertEqual)++import qualified Data.ByteString.Char8 as Char8+import qualified Data.Map as Map++import Rest.Api hiding (route)+import Rest.Driver.Perform (accept)+import Rest.Driver.RestM (runRestM_)+import Rest.Driver.Routing+import Rest.Driver.Types+import Rest.Handler+import Rest.Resource+import Rest.Schema+import Rest.Dictionary+import qualified Rest.Api as Rest+import qualified Rest.Driver.RestM as RestM++main :: IO ()+main = do+  defaultMain [ testCase "Top level listing." testListing+              , testCase "Top level listing (trailing slash)." testListingTrailingSlash+              , testCase "Top level singleton." testToplevelSingleton+              , testCase "Unnamed single." testUnnamedSingle+              , testCase "Unnamed multi." testUnnamedMulti+              , testCase "Named singleton." testNamedSingleton+              , testCase "Named single by." testNamedSingleBy+              , testCase "Named listing." testNamedListing+              , testCase "Named listing by." testNamedListingBy+              , testCase "Create." testCreate+              , testCase "Create with listing." testCreateWithListing+              , testCase "Static action." testStaticAction+              , testCase "Simple subresource." testSubresource+              , testCase "Root router is skipped." testRootRouter+              , testCase "Multi-PUT." testMultiPut+              , testCase "Multi-GET." testMultiGet+              , testCase "Accept headers." testAcceptHeaders+              ]++testListing :: Assertion+testListing = checkRoute GET "resource" (Rest.route resource)+  where+    resource :: Resource IO IO Void () Void+    resource = mkResourceId { name = "resource", schema = Schema (Just (Many ())) (Named []), list = listHandler }+    listHandler () = mkListing id $ \_ -> return []++testListingTrailingSlash :: Assertion+testListingTrailingSlash = checkRoute GET "resource/" (Rest.route resource)+  where+    resource :: Resource IO IO Void () Void+    resource = mkResourceId { name = "resource", schema = Schema (Just (Many ())) (Named []), list = listHandler }+    listHandler () = mkListing id $ \_ -> return []++testToplevelSingleton :: Assertion+testToplevelSingleton = checkSingleRoute "resource" resource handler_+  where+    resource :: Resource IO IO () Void Void+    resource = mkResourceId { name = "resource", schema = Schema (Just (Single ())) (Named []) }+    handler_ = mkConstHandler id $ return ()++testUnnamedSingle :: Assertion+testUnnamedSingle = checkSingleRoute "resource/foo" resource handler_+  where+    resource :: Resource IO (ReaderT String IO) String Void Void+    resource = mkResourceReader { name = "resource", schema = Schema Nothing (Unnamed (Single (Id StringId id))) }+    handler_ = mkConstHandler stringO ask++testUnnamedMulti :: Assertion+testUnnamedMulti = checkRoute GET "resource/foo" (Rest.route resource)+  where+    resource :: Resource IO IO Void String Void+    resource = mkResourceId { name = "resource", schema = Schema Nothing (Unnamed (Many (Id StringId id))), list = listHandler }+    listHandler (s :: String) = mkListing xmlJsonO $ \_rng -> return (void s)++testNamedSingleton :: Assertion+testNamedSingleton = checkSingleRoute "resource/foo" resource handler_+  where+    resource :: Resource IO IO () Void Void+    resource = mkResourceId { name = "resource", schema = Schema Nothing (Named [("foo", Right (Single (Singleton ())))]) }+    handler_ = mkConstHandler id $ return ()++testNamedSingleBy :: Assertion+testNamedSingleBy = checkSingleRoute "resource/foo/bar" resource handler_+  where+    resource :: Resource IO (ReaderT String IO) String Void Void+    resource = mkResourceReader { name = "resource", schema = Schema Nothing (Named [("foo", Right (Single (By (Id StringId id))))]) }+    handler_ = mkConstHandler stringO ask++testNamedListing :: Assertion+testNamedListing = checkRoute GET "resource/foo" (Rest.route resource)+  where+    resource :: Resource IO IO Void () Void+    resource = mkResourceId { name = "resource", schema = Schema Nothing (Named [("foo", Right (Many (Singleton ())))]), list = listHandler }+    listHandler () = mkListing id $ \_rng -> return []++testNamedListingBy :: Assertion+testNamedListingBy = checkRoute GET "resource/foo/bar" (Rest.route resource)+  where+    resource :: Resource IO IO Void String Void+    resource = mkResourceId { name = "resource", schema = Schema Nothing (Named [("foo", Right (Many (By (Id StringId id))))]), list = listHandler }+    listHandler (s :: String) = mkListing xmlJsonO $ \_rng -> return (void s)++testCreate :: Assertion+testCreate = checkRoute POST "resource" (root -/ Rest.route resource)+  where+    resource :: Resource IO IO Void Void Void+    resource = mkResourceId { name = "resource", schema = Schema Nothing (Named []), create = Just createHandler }+    createHandler = mkConstHandler id $ return ()++-- This one was added because the list handler didn't correctly fall+-- through to create, and testCreate didn't catch that because it+-- contains no list handler.++testCreateWithListing :: Assertion+testCreateWithListing = checkRoutes [(GET, "resource"), (POST, "resource")] (Rest.route resource)+  where+    resource :: Resource IO IO Void () Void+    resource = mkResourceId { name = "resource", schema = Schema (Just (Many ())) (Named []), list = listHandler, create = Just createHandler }+    createHandler = mkConstHandler id $ return ()+    listHandler () = mkListing id $ \_rng -> return []++testStaticAction :: Assertion+testStaticAction = checkRoute POST "resource/action" (Rest.route resource)+  where+    resource :: Resource IO IO () Void ()+    resource = mkResourceId { name = "resource", schema = Schema Nothing (Named [("action", Left ())]), statics = staticHandler }+    staticHandler () = mkConstHandler id $ return ()++testSubresource :: Assertion+testSubresource = checkRoute GET "resource/single/subresource" (Rest.route resource -/ Rest.route subResource)+  where+    resource :: Resource IO IO () Void Void+    resource = mkResourceId { name = "resource", schema = Schema Nothing (Named [("single", Right (Single (Singleton ())))]), get = Just getHandler }+    subResource :: Resource IO IO Void () Void+    subResource = mkResourceId { name = "subresource", schema = Schema (Just (Many ())) (Named []), list = listHandler }+    getHandler = mkConstHandler id $ return ()+    listHandler _ = mkListing id $ \_rng -> return []++testRootRouter :: Assertion+testRootRouter = checkRoute GET "resource/single" (Rest.root -/ Rest.route resource)+  where+    resource :: Resource IO IO () Void Void+    resource = mkResourceId { name = "resource", schema = Schema Nothing (Named [("single", Right (Single (Singleton ())))]), get = Just getHandler }+    getHandler = mkConstHandler id $ return ()++testMultiPut :: Assertion+testMultiPut = checkRouteSuccess PUT "resource/foo" (Rest.route resource)+  where+    resource :: Resource IO (ReaderT String IO) String Void Void+    resource = mkResourceReader+      { name   = "resource"+      , schema = Schema Nothing (Named [("foo", Right (Single (By (Id StringId id))))])+      , update = Just (mkConstHandler xmlJsonO (liftM void ask))+      }++testMultiGet :: Assertion+testMultiGet = checkRouteSuccess GET "" (Rest.root :: Rest.Router IO IO)++checkSingleRoute :: (Applicative m, Monad m, Monad s)+                 => Uri -> Resource m s sid mid aid -> Handler s -> Assertion+checkSingleRoute uri resource handler_ =+  do checkRoute GET    uri (root -/ Rest.route resource { get = Just handler_ })+     checkRoute PUT    uri (root -/ Rest.route resource { update = Just handler_ })+     checkRoute DELETE uri (root -/ Rest.route resource { remove = Just handler_ })+     checkRoute GET    (uri <> "/select") (root -/ Rest.route resource { selects = [("select", handler_)] })+     checkRoute POST   (uri <> "/action") (root -/ Rest.route resource { actions = [("action", handler_)] })++checkRoute :: Method -> Uri -> Rest.Router m s -> Assertion+checkRoute method uri router = checkRouteWithIgnoredMethods [method] router method uri++checkRoutes :: [(Method, Uri)] -> Rest.Router m s -> Assertion+checkRoutes reqs router =+  do forM_ reqs $ uncurry $ checkRouteWithIgnoredMethods (map fst reqs) router++checkRouteWithIgnoredMethods :: [Method] -> Rest.Router m s -> Method -> Uri -> Assertion+checkRouteWithIgnoredMethods ignoredMethods router method uri =+  do checkRouteSuccess method uri router+     forM_ (filter (not . (`elem` ignoredMethods)) allMethods) $ \badMethod -> checkRouteFailure badMethod uri router+     checkRouteFailure method (uri <> "/trailing") router++checkRouteFailure :: Method -> Uri -> Rest.Router m s -> Assertion+checkRouteFailure method uri router =+  case route method (splitUri $ "v1.0/" <> uri) [(Version 1 0 Nothing, Some1 router)] of+    Left _  -> return ()+    Right _ -> assertFailure ("Should be no route to " ++ show method ++ " " ++ Char8.unpack uri ++ ".")++checkRouteSuccess :: Method -> Uri -> Rest.Router m s -> Assertion+checkRouteSuccess method uri router =+  case route method (splitUri $ "v1.0/" <> uri) [(Version 1 0 Nothing, Some1 router)] of+    Left e  -> assertFailure ("No route to " ++ show method ++ " " ++ Char8.unpack uri ++ ": " ++ show e)+    Right _ -> return ()++allMethods :: [Method]+allMethods = [GET, PUT, POST, DELETE]++testAcceptHeaders :: Assertion+testAcceptHeaders =+  do fmt <- runRestM_ RestM.emptyInput { RestM.headers = Map.singleton "Accept" "text/json" } accept+     assertEqual "Accept json format." [JsonFormat] fmt