diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. 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/rest-core.cabal b/rest-core.cabal new file mode 100644 --- /dev/null +++ b/rest-core.cabal @@ -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 diff --git a/src/Rest.hs b/src/Rest.hs new file mode 100644 --- /dev/null +++ b/src/Rest.hs @@ -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 diff --git a/src/Rest/Api.hs b/src/Rest/Api.hs new file mode 100644 --- /dev/null +++ b/src/Rest/Api.hs @@ -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) diff --git a/src/Rest/Container.hs b/src/Rest/Container.hs new file mode 100644 --- /dev/null +++ b/src/Rest/Container.hs @@ -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 diff --git a/src/Rest/Dictionary.hs b/src/Rest/Dictionary.hs new file mode 100644 --- /dev/null +++ b/src/Rest/Dictionary.hs @@ -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 diff --git a/src/Rest/Dictionary/Combinators.hs b/src/Rest/Dictionary/Combinators.hs new file mode 100644 --- /dev/null +++ b/src/Rest/Dictionary/Combinators.hs @@ -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 diff --git a/src/Rest/Dictionary/Types.hs b/src/Rest/Dictionary/Types.hs new file mode 100644 --- /dev/null +++ b/src/Rest/Dictionary/Types.hs @@ -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 diff --git a/src/Rest/Driver/Perform.hs b/src/Rest/Driver/Perform.hs new file mode 100644 --- /dev/null +++ b/src/Rest/Driver/Perform.hs @@ -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 "" + 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] diff --git a/src/Rest/Driver/RestM.hs b/src/Rest/Driver/RestM.hs new file mode 100644 --- /dev/null +++ b/src/Rest/Driver/RestM.hs @@ -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) diff --git a/src/Rest/Driver/Routing.hs b/src/Rest/Driver/Routing.hs new file mode 100644 --- /dev/null +++ b/src/Rest/Driver/Routing.hs @@ -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 diff --git a/src/Rest/Driver/Types.hs b/src/Rest/Driver/Types.hs new file mode 100644 --- /dev/null +++ b/src/Rest/Driver/Types.hs @@ -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) diff --git a/src/Rest/Error.hs b/src/Rest/Error.hs new file mode 100644 --- /dev/null +++ b/src/Rest/Error.hs @@ -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) diff --git a/src/Rest/Handler.hs b/src/Rest/Handler.hs new file mode 100644 --- /dev/null +++ b/src/Rest/Handler.hs @@ -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)) diff --git a/src/Rest/Info.hs b/src/Rest/Info.hs new file mode 100644 --- /dev/null +++ b/src/Rest/Info.hs @@ -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" + diff --git a/src/Rest/Resource.hs b/src/Rest/Resource.hs new file mode 100644 --- /dev/null +++ b/src/Rest/Resource.hs @@ -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 } diff --git a/src/Rest/Run.hs b/src/Rest/Run.hs new file mode 100644 --- /dev/null +++ b/src/Rest/Run.hs @@ -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) diff --git a/src/Rest/Schema.hs b/src/Rest/Schema.hs new file mode 100644 --- /dev/null +++ b/src/Rest/Schema.hs @@ -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)) diff --git a/tests/Runner.hs b/tests/Runner.hs new file mode 100644 --- /dev/null +++ b/tests/Runner.hs @@ -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