airship 0.6.0 → 0.9.0

raw patch · 13 files changed

+668/−193 lines, 13 filesdep ~mmorphnew-uploaderPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: mmorph

API changes (from Hackage documentation)

Files

• Changes.md +5/−0
• LICENSE +37/−0
• README.md +23/−0
• airship.cabal +66/−60
• src/Airship/Helpers.hs +1/−0
• src/Airship/Internal/Date.hs +96/−15
• src/Airship/Internal/Decision.hs +4/−4
• src/Airship/Internal/Helpers.hs +40/−19
• src/Airship/Internal/Route.hs +174/−41
• src/Airship/RST.hs +161/−0
• src/Airship/Resource.hs +2/−1
• src/Airship/Route.hs +4/−1
• src/Airship/Types.hs +55/−52

@@ -0,0 +1,5 @@+ * 0.9.0+  - Handle unspecified content-type (#107)+  - Unroll internal webmachine monad (#108)+  - Support for GHC 8.2.1+  - Various bugfixes

@@ -18,3 +18,40 @@ CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.++Portions of this software have been extracted from the Snap framework,+which is licensed under the three-clause BSD license.++Copyright (c) 2009, Snap Framework authors (see CONTRIBUTORS)+All rights reserved.++Portions of this software have been extracted from Kazu Yamamoto's+http-date library, which is licensed under the three-clause BSD license.++Copyright (c) 2009, IIJ Innovation Institute Inc.+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 the Snap Framework authors nor the names of its+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 HOLDER 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,23 @@+# Airship++[![Join the chat at https://gitter.im/helium/airship](https://badges.gitter.im/Join%20Chat.svg)](https://gitter.im/helium/airship?utm_source=badge&utm_medium=badge&utm_campaign=pr-badge&utm_content=badge)++[![Build Status](https://travis-ci.org/helium/airship.svg?branch=master)](https://travis-ci.org/helium/airship)++Airship is a Haskell library for handling and serving HTTP requests in a RESTful fashion. It is heavily inspired by [Webmachine](https://github.com/basho/webmachine) and works with any [WAI](https://hackage.haskell.org/package/wai)-compatible web server such as [Warp](https://hackage.haskell.org/package/warp). It aims to be small, fast, and flexible.++# How does it work?++Airship resources are represented with a [`Resource` record type](https://github.com/helium/airship/blob/master/src/Airship/Resource.hs#L39-L117). Each field in `Resource` corresponds to an action taken in the [Webmachine decision tree](https://raw.githubusercontent.com/wiki/Webmachine/webmachine/images/http-headers-status-v3.png). Airship provides a `defaultResource` with sensible defaults for each of these actions; you build web services by overriding fields in the default resource with your own.++Routes are declared with a simple monadic syntax:++```haskell+routes = do+    root                        #> someRootResource+    "account" </> var "name"    #> accountResource+```++For a simple example that handles HTTP GET and POST requests, please check [`example/Basic.hs`](https://github.com/helium/airship/blob/master/example/Basic.hs). For a slightly more involved example that generates HTML and manages a pool of resources, please check the [blimp](https://github.com/patrickt/blimp) repository.++Airship is copyright &copy; 2015 Helium Systems, Inc., and released to the public under the terms of the MIT license.

@@ -1,60 +1,66 @@-name:                   airship-synopsis:               A Webmachine-inspired HTTP library-description:            A Webmachine-inspired HTTP library-homepage:               https://github.com/helium/airship/-Bug-reports:            https://github.com/helium/airship/issues-version:                0.6.0-license:                MIT-license-file:           LICENSE-author:                 Reid Draper and Patrick Thomson-maintainer:             reid@helium.com-category:               Web-build-type:             Simple-cabal-version:          >=1.10+name:                 airship+synopsis:             A Webmachine-inspired HTTP library+homepage:             https://github.com/helium/airship/+Bug-reports:          https://github.com/helium/airship/issues+version:              0.9.0+license:              MIT+license-file:         LICENSE+author:               Reid Draper and Patrick Thomson+maintainer:           Tim McGilchrist <timmcgil@gmail.com>, reid@helium.com+category:             Web+build-type:           Simple+cabal-version:        >=1.10+description:          A Webmachine-inspired HTTP library based off ideas from the original Erlang project <https://github.com/webmachine/webmachine>+                      .+                      A number of examples can be found in <https://github.com/helium/airship/tree/master/example> illustrating how to build airship based services.+extra-source-files:+  README.md+  Changes.md  source-repository head-    type: git-    location: https://github.com/helium/airship.git+    type:             git+    location:         https://github.com/helium/airship.git  library-  default-language:    Haskell2010-  hs-source-dirs: src-  ghc-options:  -Wall-  exposed-modules:   Airship-                   , Airship.Config-                   , Airship.Headers-                   , Airship.Helpers-                   , Airship.Types-                   , Airship.Resource-                   , Airship.Resource.Static-                   , Airship.Route+  default-language:   Haskell2010+  hs-source-dirs:     src+  ghc-options:        -Wall+  exposed-modules:      Airship+                      , Airship.RST+                      , Airship.Config+                      , Airship.Headers+                      , Airship.Helpers+                      , Airship.Types+                      , Airship.Resource+                      , Airship.Resource.Static+                      , Airship.Route -  other-modules:     Airship.Internal.Route-                   , Airship.Internal.Date-                   , Airship.Internal.Decision-                   , Airship.Internal.Helpers-                   , Airship.Internal.Parsers+  other-modules:        Airship.Internal.Route+                      , Airship.Internal.Date+                      , Airship.Internal.Decision+                      , Airship.Internal.Helpers+                      , Airship.Internal.Parsers    build-depends:        attoparsec-                      , base >= 4.7 && < 5-                      , base64-bytestring == 1.0.*-                      , blaze-builder >= 0.3 && < 0.5+                      , base                    >= 4.7     && < 5+                      , base64-bytestring       == 1.0.*+                      , blaze-builder           >= 0.3     && < 0.5                       , bytestring-                      , bytestring-trie == 0.2.4.*+                      , bytestring-trie         == 0.2.4.*                       , case-insensitive                       , containers-                      , cryptohash == 0.11.*+                      , cryptohash              == 0.11.*                       , directory-                      , either >= 4.3 && < 4.6-                      , filepath >= 1.3 && < 1.5+                      , either                  >= 4.3     && < 4.6+                      , filepath                >= 1.3     && < 1.5                       , http-date                       , http-media-                      , http-types >= 0.8 && <0.10-                      , lifted-base == 0.2.*+                      , http-types              >= 0.8     && <0.10+                      , lifted-base             == 0.2.*                       , microlens-                      , monad-control >= 1.0-                      , mime-types == 0.1.0.*-                      , mmorph == 1.0.*+                      , monad-control           >= 1.0+                      , mime-types              == 0.1.0.*+                      , mmorph                  >= 1.0     && < 1.2                       , mtl                       , network                       , old-locale@@ -63,24 +69,24 @@                       , time                       , transformers                       , transformers-base-                      , unix == 2.7.*+                      , unix                    == 2.7.*                       , unordered-containers-                      , wai >= 3.0 && < 3.3-                      , wai-extra == 3.0.*+                      , wai                     >= 3.0     && < 3.3+                      , wai-extra               == 3.0.*  test-suite unit-  default-language: Haskell2010-  type: exitcode-stdio-1.0-  hs-source-dirs: test/unit-  main-is: test.hs-  build-depends: base             >= 4.7     && < 5-               , airship-               , text             == 1.2.*-               , bytestring       >= 0.9.1   && < 0.11-               , tasty            >= 0.10.1  && < 0.12-               , tasty-quickcheck >= 0.8.3   && < 0.8.5-               , tasty-hunit        >= 0.9.1 && < 0.10-               , transformers-               , wai >= 3.0 && < 3.3+  default-language:   Haskell2010+  type:               exitcode-stdio-1.0+  hs-source-dirs:     test/unit+  main-is:            test.hs+  build-depends:        base                    >= 4.7     && < 5+                      , airship+                      , text                    == 1.2.*+                      , bytestring              >= 0.9.1   && < 0.11+                      , tasty                   >= 0.10.1  && < 0.12+                      , tasty-quickcheck        >= 0.8.3   && < 0.8.5+                      , tasty-hunit             >= 0.9.1   && < 0.10+                      , transformers+                      , wai                     >= 3.0     && < 3.3 -  ghc-options: -Wall -threaded -O1 -fno-warn-orphans+  ghc-options:        -Wall -threaded -fno-warn-orphans

@@ -5,6 +5,7 @@     , redirectPermanently     , resourceToWai     , resourceToWaiT+    , resourceToWaiT'     , appendRequestPath     , lookupParam     , lookupParam'

@@ -1,26 +1,31 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE CPP               #-}+{-# LANGUAGE OverloadedStrings #-} +{-+   Portions of this file are copyright (c) 2009,  IIJ Innovation Institute Inc.+   The utcTimeToRfc1123 function was extracted from http-date, with slight+   modifications to operate on UTCTime values.+-}+ module Airship.Internal.Date     ( parseRfc1123Date     , utcTimeToRfc1123) where  #if __GLASGOW_HASKELL__ < 710-import           Control.Applicative ((<$>))+import           Control.Applicative         ((<$>)) #endif -import           Data.ByteString.Char8 (ByteString, pack)-import           Data.Time.Calendar (fromGregorian)-import           Data.Time.Clock (UTCTime(..), secondsToDiffTime)--#if MIN_VERSION_time(1,5,0)-import           Data.Time.Format (formatTime, defaultTimeLocale)-#else--- get defaultTimeLocale from old-locale-import           Data.Time.Format (formatTime)-import           System.Locale (defaultTimeLocale)-#endif+import           Data.ByteString.Char8       ()+import           Data.ByteString.Internal+import           Data.Time.Calendar          (fromGregorian, toGregorian)+import           Data.Time.Calendar.WeekDate (toWeekDate)+import           Data.Time.Clock             (UTCTime (..), secondsToDiffTime)+import           Data.Word+import           Foreign.ForeignPtr+import           Foreign.Ptr+import           Foreign.Storable -import qualified Network.HTTP.Date as HD+import qualified Network.HTTP.Date           as HD  httpDateToUtc :: HD.HTTPDate -> UTCTime httpDateToUtc h = UTCTime days diffTime@@ -34,4 +39,80 @@ parseRfc1123Date b = httpDateToUtc <$> HD.parseHTTPDate b  utcTimeToRfc1123 :: UTCTime -> ByteString-utcTimeToRfc1123 utc = pack $ formatTime defaultTimeLocale "%a, %d %b %Y %H:%M:%S GMT" utc+utcTimeToRfc1123 (UTCTime day offset) =+    unsafeCreate 29 $ \ptr -> do+        cpy3 ptr weekDays (3 * w)+        poke (ptr `plusPtr`  3) comma+        poke (ptr `plusPtr`  4) spc+        int2 (ptr `plusPtr`  5) d+        poke (ptr `plusPtr`  7) spc+        cpy3 (ptr `plusPtr`  8) months (3 * m)+        poke (ptr `plusPtr` 11) spc+        int4 (ptr `plusPtr` 12) y+        poke (ptr `plusPtr` 16) spc+        int2 (ptr `plusPtr` 17) h+        poke (ptr `plusPtr` 19) colon+        int2 (ptr `plusPtr` 20) n+        poke (ptr `plusPtr` 22) colon+        int2 (ptr `plusPtr` 23) s+        poke (ptr `plusPtr` 25) spc+        poke (ptr `plusPtr` 26) (71 :: Word8)+        poke (ptr `plusPtr` 27) (77 :: Word8)+        poke (ptr `plusPtr` 28) (84 :: Word8)+  where+    y = fromIntegral y'+    offset' = round offset+    h = offset' `mod` 3600+    n = offset' `mod` 60+    s = offset' - (h * 3600) - (n * 60)+    (y', m, d) = toGregorian day+    (_, _, w) = toWeekDate day+    cpy3 :: Ptr Word8 -> ForeignPtr Word8 -> Int -> IO ()+    cpy3 ptr p o = withForeignPtr p $ \fp ->+      memcpy ptr (fp `plusPtr` o) 3++----------------------------------------------------------------++int2 :: Ptr Word8 -> Int -> IO ()+int2 ptr n+  | n < 10 = do+      poke ptr zero+      poke (ptr `plusPtr` 1) (i2w8 n)+  | otherwise = do+      poke ptr               (i2w8 (n `quot` 10))+      poke (ptr `plusPtr` 1) (i2w8 (n `rem` 10))++int4 :: Ptr Word8 -> Int -> IO ()+int4 ptr n0 = do+    let (n1,x1) = n0 `quotRem` 10+        (n2,x2) = n1 `quotRem` 10+        (x4,x3) = n2 `quotRem` 10+    poke ptr               (i2w8 x4)+    poke (ptr `plusPtr` 1) (i2w8 x3)+    poke (ptr `plusPtr` 2) (i2w8 x2)+    poke (ptr `plusPtr` 3) (i2w8 x1)++i2w8 :: Int -> Word8+i2w8 n = fromIntegral n + zero++----------------------------------------------------------------++months :: ForeignPtr Word8+months = let (PS p _ _) = "___JanFebMarAprMayJunJulAugSepOctNovDec" in p++weekDays :: ForeignPtr Word8+weekDays = let (PS p _ _) = "___MonTueWedThuFriSatSun" in p++----------------------------------------------------------------++spc :: Word8+spc = 32++comma :: Word8+comma = 44++colon :: Word8+colon = 58++zero :: Word8+zero = 48

@@ -17,7 +17,8 @@                                                    Resource (..)) import           Airship.Types                    (Response (..),                                                    ResponseBody (..),-                                                   Webmachine, etagToByteString,+                                                   Webmachine, addTrace,+                                                   etagToByteString,                                                    getResponseBody,                                                    getResponseHeaders, halt,                                                    pathInfo, putResponseBody,@@ -30,7 +31,6 @@ import           Control.Monad.Trans              (lift) import           Control.Monad.Trans.State.Strict (StateT (..), evalStateT, get,                                                    modify)-import           Control.Monad.Writer.Class       (tell)   import           Blaze.ByteString.Builder         (toByteString)@@ -81,8 +81,8 @@ flow :: Monad m => Resource m -> Webmachine m Response flow r = evalStateT (b13 r) initFlowState -trace :: Monad m => Text -> FlowStateT m ()-trace t = lift $ tell [t]+trace :: Monad m => ByteString -> FlowStateT m ()+trace a = lift $ addTrace a  ----------------------------------------------------------------------------- -- Header value data newtypes

@@ -11,6 +11,7 @@     , redirectPermanently     , resourceToWai     , resourceToWaiT+    , resourceToWaiT'     , appendRequestPath     , lookupParam     , lookupParam'@@ -20,7 +21,7 @@ import           Control.Applicative #endif import           Control.Monad             (join)-import           Data.ByteString           (ByteString)+import           Data.ByteString           (ByteString, intercalate) import qualified Data.ByteString.Lazy      as LB import           Data.Maybe #if __GLASGOW_HASKELL__ < 710@@ -29,8 +30,8 @@ import           Data.Foldable             (forM_) import qualified Data.HashMap.Strict       as HM import qualified Data.Map.Strict           as M-import           Data.Text                 (Text, intercalate)-import           Data.Text.Encoding+import           Data.Text                 (Text)+import           Data.Text.Encoding        (decodeUtf8) import           Data.Time                 (getCurrentTime) import           Lens.Micro                ((^.)) import           Network.HTTP.Media@@ -105,29 +106,49 @@ resourceToWai cfg routes errors =     resourceToWaiT cfg (const id) routes errors --- | Given a 'RoutingSpec', an 'ErrorResponses', and a user state @s@, construct a WAI 'Application'.-resourceToWaiT :: Monad m =>-                  AirshipConfig-               -> (Request -> m Wai.Response -> IO Wai.Response)+-- | Given a 'AirshipConfig, a function to modify the 'Response' based on the+-- 'AirshipRequest' and the 'Response' (like WAI middleware), a 'RoutingSpec,+-- and 'ErrorResponses' construct a WAI 'Application'.+resourceToWaiT :: Monad m+               => AirshipConfig+               -> (AirshipRequest -> m Wai.Response -> IO Wai.Response)                -> RoutingSpec m ()                -> ErrorResponses m                -> Wai.Application-resourceToWaiT cfg run routes errors req respond = do-    let routeMapping = runRouter routes-        pInfo = Wai.pathInfo req+resourceToWaiT cfg run routes errors req respond =+    resourceToWaiT' cfg run (runRouter routes) errors req respond++-- | Like 'resourceToWaiT', but expects the 'RoutingSpec' to have been+-- evaluated with 'runRouter'. This is more efficient than 'resourceToWaiT', as+-- the routes will not be evaluated on every request.+-- +-- Given @routes :: RoutingSpec IO ()@, 'resourceToWaiT'' can be invoked like so:+--+-- > resourceToWaiT' cfg (const id) (runRouter routes) errors+resourceToWaiT' :: Monad m+               => AirshipConfig+               -> (AirshipRequest -> m Wai.Response -> IO Wai.Response)+               -> Trie (RouteLeaf m)+               -> ErrorResponses m+               -> Wai.Application+resourceToWaiT' cfg run routeMapping errors req respond = do+    let pInfo = Wai.rawPathInfo req     quip <- getQuip     nowTime <- getCurrentTime-    let (er, (ps, matched), r) =+    let (er, (reqParams, dispatched), routePath', r) =          case route routeMapping pInfo of              Nothing ->-                 (errors, (mempty, []), return $ Response HTTP.status404 [(HTTP.hContentType, "text/plain")] Empty)-             Just (resource, pm) ->-                 (M.union (errorResponses resource) errors, pm, flow resource)-    respond =<< run req (do-        (response, trace) <- eitherResponse nowTime ps matched req (r >>= errorResponse er)+                 (errors, (mempty, []), decodeUtf8 pInfo, return $ Response HTTP.status404 [(HTTP.hContentType, "text/plain")] Empty)+             Just (RoutedResource rPath resource, pm) ->+                 (M.union (errorResponses resource) errors, pm, routeText rPath, flow resource)+        airshipReq = AirshipRequest req routePath'+        requestReader = RequestReader nowTime airshipReq+        startingState = ResponseState [] Empty reqParams dispatched []+    respond =<< run airshipReq (do+        (response, trace) <-+            eitherResponse requestReader startingState (r >>= errorResponse er)         return $ toWaiResponse response cfg (traceHeader trace) quip) - -- | If the Response body is Empty the response body is set based on the error responses --  provided by the application and resource. If the response body is not Empty or --  there are no error response configured for the status code in the Response then no@@ -176,8 +197,8 @@                 , "shut it down"                 ] -traceHeader :: [Text] -> ByteString-traceHeader = encodeUtf8 . intercalate ","+traceHeader :: [ByteString] -> ByteString+traceHeader = intercalate ","  -- | Lookup routing parameter and return 500 Internal Server Error if not found. -- Not finding the paramter usually means the route doesn't match what

@@ -1,22 +1,48 @@-{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE CPP                        #-}+{-# LANGUAGE FlexibleContexts           #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses      #-} {-# LANGUAGE OverloadedStrings          #-}+{-# OPTIONS_HADDOCK hide                #-} -module Airship.Internal.Route where+module Airship.Internal.Route+    ( RoutingSpec+    , Route+    , RouteLeaf+    , RoutedResource(..)+    , Trie+    , root+    , var+    , star+    , (</>)+    , (#>)+    , (#>=)+    , runRouter+    , route+    , routeText+    ) where -import           Airship.Resource+import           Airship.Resource           as Resource -import           Data.Foldable              (foldr')-import           Data.HashMap.Strict        (HashMap, insert)+import           Control.Monad.Writer.Class (MonadWriter, tell)+import qualified Data.ByteString            as B+import qualified Data.ByteString.Base64     as Base64+import qualified Data.ByteString.Char8      as BC8+import           Data.HashMap.Strict        (HashMap, fromList)+import qualified Data.List                  as L (foldl')+import           Data.Maybe                 (isNothing) import           Data.Monoid import           Data.Text                  (Text)+import qualified Data.Text                  as T (intercalate, cons)+import           Data.Text.Encoding         (encodeUtf8, decodeUtf8)+import           Data.Trie                  (Trie)+import qualified Data.Trie                  as Trie + #if __GLASGOW_HASKELL__ < 710 import           Control.Applicative #endif import           Control.Monad.Writer       (Writer, WriterT (..), execWriter)-import           Control.Monad.Writer.Class (MonadWriter)  import           Data.String                (IsString, fromString) @@ -25,16 +51,60 @@ -- named variables with the 'var' combinator, and wildcards with 'star'. newtype Route = Route { getRoute :: [BoundOrUnbound] } deriving (Show, Monoid) +routeText :: Route -> Text+routeText (Route parts) =+    T.cons '/' $ T.intercalate "/" ((boundOrUnboundText <$> parts))+ data BoundOrUnbound = Bound Text                     | Var Text                     | RestUnbound deriving (Show) ++boundOrUnboundText :: BoundOrUnbound -> Text+boundOrUnboundText (Bound t) = t+boundOrUnboundText (Var t) = ":" <> t+boundOrUnboundText (RestUnbound) = "*"++++ instance IsString Route where     fromString s = Route [Bound (fromString s)] -runRouter :: RoutingSpec m a -> [(Route, Resource m)]-runRouter routes = execWriter (getRouter routes) +data RoutedResource m+    = RoutedResource Route (Resource m)+++data RouteLeaf m = RouteMatch (RoutedResource m) [Text]+                 | RVar+                 | RouteMatchOrVar (RoutedResource m) [Text]+                 | Wildcard (RoutedResource m)+++-- | Turns the list of routes in a 'RoutingSpec' into a 'Trie' for efficient+-- routing+runRouter :: RoutingSpec m a -> Trie (RouteLeaf m)+runRouter routes = toTrie $ execWriter (getRouter routes)+    where+        -- Custom version of Trie.fromList that resolves key conflicts+        -- in the desired manner. In the case of duplicate routes the+        -- routes specified first are favored over any subsequent+        -- specifications.+        toTrie = L.foldl' insertOrReplace Trie.empty+        insertOrReplace t (k, v) =+            let newV = maybe v (mergeValues v) $ Trie.lookup k t+            in Trie.insert k newV t+        mergeValues (Wildcard x) _                              = Wildcard x+        mergeValues _ (Wildcard x)                                     = Wildcard x+        mergeValues RVar RVar                                   = RVar+        mergeValues RVar (RouteMatch x y)                       = RouteMatchOrVar x y+        mergeValues (RouteMatch _ _) (RouteMatch x y)           = RouteMatch x y+        mergeValues (RouteMatch x y) RVar                       = RouteMatchOrVar x y+        mergeValues (RouteMatchOrVar _ _) (RouteMatch x y)      = RouteMatchOrVar x y+        mergeValues (RouteMatchOrVar x y) _                     = RouteMatchOrVar x y+        mergeValues _ v                                                = v+ -- | @a '</>' b@ separates the path components @a@ and @b@ with a slash. -- This is actually just a synonym for 'mappend'. (</>) :: Route -> Route -> Route@@ -65,6 +135,42 @@ star :: Route star = Route [RestUnbound] ++-- Routing trie creation algorithm+-- 1. Store full paths as keys up to first `var`+-- 2. Calculate Base64 encoding of the URL portion preceding the+--    `var` ++ "var" and use that as key for the next part of the+--    route spec.+-- 3. Repeat step 2 for every `var` encountered until the route+ --   is completed and maps to a resource.+(#>) :: MonadWriter [(B.ByteString, (RouteLeaf a))] m+     => Route -> Resource a -> m ()+k #> v = do+    let (key, routes, vars, isWild) = foldl routeFoldFun ("", [], [], False) (getRoute k)+        key' = if BC8.null key then "/"+               else key+        ctor = if isWild+                  then Wildcard (RoutedResource k v)+                  else RouteMatch (RoutedResource k v) vars+    tell $ (key', ctor) : routes+    where+        routeFoldFun (kps, rt, vs, False) (Bound x) =+            (B.concat [kps, "/", encodeUtf8 x], rt, vs, False)+        routeFoldFun (kps, rt, vs, False) (Var x) =+            let partKey = Base64.encode $ B.concat [kps, "var"]+                rt' = (kps, RVar) : rt+            in (partKey, rt', x:vs, False)+        routeFoldFun (kps, rt, vs, False) RestUnbound =+            (kps, rt, vs, True)+        routeFoldFun (kps, rt, vs, True) _ =+            (kps, rt, vs, True)+++(#>=) :: MonadWriter [(B.ByteString, (RouteLeaf a))] m+      => Route -> m (Resource a) -> m ()+k #>= mv = mv >>= (k #>)++ -- | Represents a fully-specified set of routes that map paths (represented as 'Route's) to 'Resource's. 'RoutingSpec's are declared with do-notation, to wit: -- -- @@@ -76,40 +182,67 @@ --      "anything" '</>' star                  #> wildcardResource -- @ ---newtype RoutingSpec m a = RoutingSpec { getRouter :: Writer [(Route, Resource m)] a }-    deriving (Functor, Applicative, Monad, MonadWriter [(Route, Resource m)])+newtype RoutingSpec m a = RoutingSpec {+        getRouter :: Writer [(B.ByteString, RouteLeaf m)] a+    } deriving ( Functor, Applicative, Monad+               , MonadWriter [(B.ByteString, RouteLeaf m)]+               ) -type MatchedRoute a = (a, (HashMap Text Text, [Text])) -route :: [(Route, a)]-      -> [Text]-      -> Maybe (MatchedRoute a)-route routes pInfo = foldr' (matchRoute pInfo) Nothing routes+route :: Trie (RouteLeaf a)+      -> BC8.ByteString+      -> Maybe (RoutedResource a, (HashMap Text Text, [Text]))+route routes pInfo = let matchRes = Trie.match routes pInfo+                     in matchRoute' routes matchRes mempty Nothing -matchRoute :: [Text]-           -> (Route, a)-           -> Maybe (MatchedRoute a)-           -> Maybe (MatchedRoute a)-matchRoute paths (rSpec, resource) previousMatch =-    case matchesRoute paths rSpec of-      Nothing -> previousMatch-      Just m  -> Just (resource, m) -matchesRoute :: [Text] -> Route -> Maybe (HashMap Text Text, [Text])-matchesRoute paths spec = matchesRoute' paths (getRoute spec) (mempty, mempty) False where-    -- recursion is over, and we never bailed out to return false, so we match-    matchesRoute' []        []              acc     _   = Just acc-    -- there is an extra part of the path left, and we don't have more matching-    matchesRoute' (_ph:_ptl) []             _       _   = Nothing-    -- we match whatever is left, so it doesn't matter what's left in the path-    matchesRoute' r        (RestUnbound:_) (h, d)  _   = Just (h, d ++ r)-    -- we match a specific string, and it matches this part of the path,-    -- so recur-    matchesRoute' (ph:ptl)  (Bound sh:stt)  (h, dispatch) True-        | ph == sh-                                                    = matchesRoute' ptl stt (h, dispatch ++ [ph]) True-    matchesRoute' (ph:ptl)  (Bound sh:stt)  (h, dispatch) False-        | ph == sh-                                                    = matchesRoute' ptl stt (h, dispatch) False-    matchesRoute' (ph:ptl)  (Var t:stt)     acc   _ = matchesRoute' ptl stt (insert t ph (fst acc), snd acc) True-    matchesRoute' _         _               _acc  _ = Nothing+matchRoute' :: Trie (RouteLeaf a)+            -> Maybe (B.ByteString, RouteLeaf a, B.ByteString)+            -> [Text]+            -> Maybe B.ByteString+            -> Maybe (RoutedResource a, (HashMap Text Text, [Text]))+matchRoute' _routes Nothing _ps _dsp =+    -- Nothing even partially matched the route+    Nothing+matchRoute' routes (Just (matched, RouteMatchOrVar r vars, "")) ps dsp =+    -- The matched key is also a prefix of other routes, but the+    -- entire path matched so handle like a RouteMatch.+    matchRoute' routes (Just (matched, RouteMatch r vars, "")) ps dsp+matchRoute' _routes (Just (matched, RouteMatch r vars, "")) ps dsp =+    -- The entire path matched so return the resource, params, and+    -- dispatch path+    Just (r, (fromList $ zip vars ps, dispatchList dsp matched))+    where+        dispatchList (Just d) m = toTextList $ B.concat [d, m]+        dispatchList Nothing _ = mempty+        toTextList bs = decodeUtf8 <$> BC8.split '/' bs+matchRoute' _routes (Just (_matched, RouteMatch _r _vars, _)) _ps _dsp =+    -- Part of the request path matched, but the trie value at the+    -- matched prefix is not an RVar or RouteMatchOrVar so there is no+    -- match.+    Nothing+matchRoute' routes (Just (matched, RouteMatchOrVar _r _vars, rest)) ps dsp =+    -- Part of the request path matched and the trie value at the+    -- matched prefix is a RouteMatchOrVar so handle it the same as if+    -- the value were RVar.+    matchRoute' routes (Just (matched, RVar, rest)) ps dsp+matchRoute' routes (Just (matched, RVar, rest)) ps dsp+    | BC8.null rest = Nothing+    | BC8.take 2 rest == "//" = Nothing+    | BC8.head rest == '/' =+        -- Part of the request path matched and the trie value at the+        -- matched prefix is a RVar so calculate the key for the next part+        -- of the route and continue attempting to match.+        let nextKey = B.concat [ Base64.encode $ B.concat [matched, "var"]+                               , BC8.dropWhile (/='/') $ BC8.dropWhile (=='/') rest+                               ]+            updDsp = if isNothing dsp then Just mempty+                     else dsp+            paramVal = decodeUtf8 . BC8.takeWhile (/='/')+                       $ BC8.dropWhile (=='/') rest+            matchRes = Trie.match routes nextKey+        in matchRoute' routes matchRes (paramVal:ps) updDsp+    | otherwise = Nothing+matchRoute' _routes (Just (_matched, Wildcard r, rest)) _ps _dsp =+    -- Encountered a wildcard (star) value in the trie so it's a match+    Just (r, (mempty, decodeUtf8 <$> [BC8.dropWhile (=='/') rest]))

@@ -0,0 +1,161 @@+{-+  This file is copyright (c) 2009, the Snap Framework authors,+  and Patrick Thomson (for the Airship project).+  Used under the three-clause BSD license, the text of which may be+  found in the LICENSE file in the Airship root.+-}++{-# LANGUAGE BangPatterns          #-}+{-# LANGUAGE CPP                   #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE UndecidableInstances  #-}++{-+  RST is like the RWST monad, but has no Writer instance, as Writer leaks space.+  This file is almost entirely lifted from the Snap framework's implementation.+-}++module Airship.RST+       ( RST (..)+       , evalRST+       , execRST+       , mapRST+       , withRST+       , failure+       ) where++import           Control.Applicative         (Alternative (..),+                                              Applicative (..))+import           Control.Category            ((.))+import           Control.Monad               (MonadPlus (..), ap)+import           Control.Monad.Base          (MonadBase (..))+import           Control.Monad.Reader        (MonadReader (..))+import           Control.Monad.State.Class   (MonadState (..))+import           Control.Monad.Trans         (MonadIO (..), MonadTrans (..))+import           Control.Monad.Trans.Control (ComposeSt, MonadBaseControl (..),+                                              MonadTransControl (..),+                                              defaultLiftBaseWith,+                                              defaultRestoreM)+import           Data.Either+import           Prelude                     (Functor (..), Monad (..), seq,+                                              ($), ($!))+++newtype RST r s e m a = RST { runRST :: r -> s -> m (Either e a, s) }+++evalRST :: Monad m => RST r s e m a -> r -> s -> m (Either e a)+evalRST m r s = do+    (res, _) <- runRST m r s+    return $! res+{-# INLINE evalRST #-}+++execRST :: Monad m => RST r s e m a -> r -> s -> m s+execRST m r s = do+    (_,!s') <- runRST m r s+    return $! s'+{-# INLINE execRST #-}+++withRST :: Monad m => (r' -> r) -> RST r s e m a -> RST r' s e m a+withRST f m = RST $ \r' s -> runRST m (f r') s+{-# INLINE withRST #-}+++instance (Monad m) => MonadReader r (RST r s e m) where+    ask = RST $ \r s -> return $! (Right r,s)+    local f m = RST $ \r s -> runRST m (f r) s++-- Terrible hack to work around the fact that Functor isn't a superclass+-- of Monad on GHC 7.8. TODO kill this when 7.8 support is dropped+#if __GLASGOW_HASKELL__ == 708+instance (Monad m) => Functor (RST r s e m) where+    fmap f m = RST $ \r s -> runRST m r s >>= helper where+      helper (a, s') = case a of+          (Left l) -> return $! (Left l, s')+          (Right r) -> return $! (Right $ f r, s')+#else+instance (Functor m) => Functor (RST r s e m) where+    fmap f m = RST $ \r s -> fmap (\(a,s') -> (fmap f a, s')) $ runRST m r s+#endif++instance Monad m => Applicative (RST r s e m) where+    pure = return+    (<*>) = ap+++instance MonadPlus m => Alternative (RST r s e m) where+    empty = mzero+    (<|>) = mplus+++instance (Monad m) => MonadState s (RST r s e m) where+    get   = RST $ \_ s -> return $! (Right s,s)+    put x = RST $ \_ _ -> return $! (Right (),x)+    state act = RST $ \_ s -> do+      let (res, !s') = act s+      return $! (Right res, s')+++mapRST :: (m (Either e a, s) -> n (Either e b, s)) -> RST r s e m a -> RST r s e n b+mapRST f m = RST $ \r s -> f (runRST m r s)++rwsBind :: Monad m =>+           RST r s e m a+        -> (a -> RST r s e m b)+        -> RST r s e m b+rwsBind m f = RST go+  where+    go r !s = do+        (a, !s')  <- runRST m r s+        case a of+            Left e  -> return $! (Left e, s')+            Right a' ->  runRST (f a') r s'+{-# INLINE rwsBind #-}++instance (Monad m) => Monad (RST r s e m) where+    return a = RST $ \_ s -> return $! (Right a, s)+    (>>=)    = rwsBind+    fail msg = RST $ \_ _ -> fail msg+++instance (MonadPlus m) => MonadPlus (RST r s e m) where+    mzero       = RST $ \_ _ -> mzero+    m `mplus` n = RST $ \r s -> runRST m r s `mplus` runRST n r s+++instance (MonadIO m) => MonadIO (RST r s e m) where+    liftIO = lift . liftIO+++instance MonadTrans (RST r s e) where+    lift m = RST $ \_ s -> do+        a <- m+        return $ s `seq` (Right a, s)+++instance MonadBase b m => MonadBase b (RST r s e m) where+    liftBase = lift . liftBase+++instance MonadBaseControl b m => MonadBaseControl b (RST r s e m) where+     type StM (RST r s e m) a = ComposeSt (RST r s e) m a+     liftBaseWith = defaultLiftBaseWith+     restoreM = defaultRestoreM+     {-# INLINE liftBaseWith #-}+     {-# INLINE restoreM #-}++instance MonadTransControl (RST r s e) where+    type StT (RST r s e) a = (Either e a, s)+    liftWith f = RST $ \r s -> do+        res <- f $ \(RST g) -> g r s+        return $! (Right res, s)+    restoreT k = RST $ \_ _ -> k+    {-# INLINE liftWith #-}+    {-# INLINE restoreT #-}++failure :: Monad m => e -> RST r s e m a+failure e = RST $ \_ s -> return $! (Left e, s)

@@ -15,7 +15,7 @@  import           Data.ByteString    (ByteString) #if __GLASGOW_HASKELL__ < 710-import           Data.Monoid        (mempty)+import           Data.Monoid        (mappend, mempty) #endif import           Data.Text          (Text) import           Data.Time.Clock    (UTCTime)@@ -115,6 +115,7 @@              , validContentHeaders       :: Webmachine m Bool              , errorResponses            :: ErrorResponses m              }+  -- | A helper function that terminates execution with @500 Internal Server Error@. serverError :: Monad m => Webmachine m a

@@ -1,12 +1,15 @@ module Airship.Route     ( Route     , RoutingSpec+    , RouteLeaf+    , Trie     , root     , var     , star     , (</>)     , (#>)+    , (#>=)+    , runRouter     ) where -import           Airship.Types import           Airship.Internal.Route

@@ -13,11 +13,14 @@ module Airship.Types     ( ETag(..)     , Webmachine+    , AirshipRequest(..)     , Request(..)+    , RequestReader(..)     , Response(..)     , ResponseState(..)     , ResponseBody(..)     , ErrorResponses+    , addTrace     , defaultRequest     , entireRequestBody     , etagToByteString@@ -27,6 +30,7 @@     , runWebmachine     , request     , requestTime+    , routePath     , getResponseHeaders     , getResponseBody     , params@@ -35,9 +39,9 @@     , putResponseBS     , halt     , finishWith-    , (#>)     ) where +import           Airship.RST import           Blaze.ByteString.Builder            (Builder) import           Blaze.ByteString.Builder.ByteString (fromByteString) import           Blaze.ByteString.Builder.Html.Utf8  (fromHtmlEscapedText)@@ -51,14 +55,9 @@ import           Control.Monad.IO.Class              (MonadIO, liftIO) import           Control.Monad.Morph import           Control.Monad.Reader.Class          (MonadReader, ask)-import           Control.Monad.State.Class           (MonadState, get, modify)+import           Control.Monad.State.Class import           Control.Monad.Trans.Control         (MonadBaseControl (..))-import           Control.Monad.Trans.Either          (EitherT (..), left,-                                                      mapEitherT, runEitherT)-import           Control.Monad.Trans.RWS.Strict      (RWST (..), mapRWST,-                                                      runRWST)-import           Control.Monad.Writer.Class          (MonadWriter, tell)-import           Data.ByteString.Char8+import           Data.ByteString.Char8               hiding (reverse) import           Data.HashMap.Strict                 (HashMap) import           Data.Map.Strict                     (Map) import           Data.Monoid                         ((<>))@@ -82,10 +81,16 @@             | BS.null prev = return acc             | otherwise = liftIO (requestBody req) >>= strictRequestBody' (acc <> LB.fromStrict prev) -data RequestReader = RequestReader { _now     :: UTCTime-                                   , _request :: Request-                                   }+data RequestReader = RequestReader+      { _now            :: UTCTime+      , _airshipRequest :: AirshipRequest+      } +data AirshipRequest = AirshipRequest+    { _request   :: Request+    , _routePath :: Text+    }+ data ETag = Strong ByteString           | Weak ByteString           deriving (Eq, Ord)@@ -117,24 +122,27 @@                                    , stateBody     :: ResponseBody                                    , _params       :: HashMap Text Text                                    , _dispatchPath :: [Text]+                                   , decisionTrace :: Trace                                    } -type Trace = [Text]+type Trace = [ByteString]  type ErrorResponses m = Monad m => Map HTTP.Status [(MediaType, Webmachine m ResponseBody)]  newtype Webmachine m a =-    Webmachine { getWebmachine :: EitherT Response (RWST RequestReader Trace ResponseState m) a }+    Webmachine { getWebmachine :: (RST RequestReader ResponseState Response m) a }         deriving (Functor, Applicative, Monad, MonadIO, MonadBase b,                   MonadReader RequestReader,-                  MonadWriter Trace,                   MonadState ResponseState)  instance MonadTrans Webmachine where-    lift = Webmachine . EitherT . (>>= return . Right) . lift+    lift = Webmachine . RST . helper where+      helper m _ s = do+          a <- m+          return $ (Right a, s)  newtype StMWebmachine m a = StMWebmachine {-      unStMWebmachine :: StM (EitherT Response (RWST RequestReader Trace ResponseState m)) a+      unStMWebmachine :: StM (RST RequestReader ResponseState Response m) a     }  instance MonadBaseControl b m => MonadBaseControl b (Webmachine m) where@@ -146,13 +154,28 @@                      $ g' $ getWebmachine m   restoreM = Webmachine . restoreM . unStMWebmachine +-- Work around old versions of mtl not having a strict modify function+modify'' :: MonadState s m => (s -> s) -> m ()+#if MIN_VERSION_mtl(2,2,0)+modify'' = modify'+#else+modify'' f = state (\s -> let s' = f s in s' `seq` ((), s'))+#endif+ -- Functions inside the Webmachine Monad ------------------------------------- ------------------------------------------------------------------------------  -- | Returns the 'Request' that is currently being processed. request :: Monad m => Webmachine m Request-request = _request <$> ask+request = _request . _airshipRequest <$> ask +-- | Returns the route path that was matched during route evaluation. This is+-- not the path specified in the request, but rather the route in the+-- 'RoutingSpec' that matched the request URL. Variables names are prefixed+-- with @:@, and free ("star") paths are designated with @*@.+routePath :: Monad m => Webmachine m Text+routePath = _routePath . _airshipRequest <$> ask+ -- | Returns the bound routing parameters extracted from the routing system (see "Airship.Route"). params :: Monad m => Webmachine m (HashMap Text Text) params = _params <$> get@@ -174,7 +197,7 @@  -- | Given a new 'ResponseBody', replaces the stored body with the new one. putResponseBody :: Monad m => ResponseBody -> Webmachine m ()-putResponseBody b = modify updateState+putResponseBody b = modify'' updateState     where updateState rs = rs {stateBody = b}  -- | Stores the provided 'ByteString' as the responseBody. This is a shortcut for@@ -191,47 +214,27 @@  -- | Immediately halts processing and writes the provided 'Response' back to the client. finishWith :: Monad m => Response -> Webmachine m a-finishWith = Webmachine . left+finishWith = Webmachine . failure --- | The @#>@ operator provides syntactic sugar for the construction of association lists.--- For example, the following assoc list:------ @---     [("run", "jewels"), ("blue", "suede"), ("zion", "wolf")]--- @------ can be represented as such:------ @---     execWriter $ do---       "run" #> "jewels"---       "blue" #> "suede"---       "zion" #> "wolf"--- @------ It used in 'RoutingSpec' declarations to indicate that a particular 'Route' maps--- to a given 'Resource', but can be used in many other places where association lists--- are expected, such as 'contentTypesProvided'.-(#>) :: MonadWriter [(k, v)] m => k -> v -> m ()-k #> v = tell [(k, v)]+-- | Adds the provided ByteString to the Airship-Trace header.+addTrace :: Monad m => ByteString -> Webmachine m ()+addTrace t = modify'' (\s -> s { decisionTrace = t : decisionTrace s })  both :: Either a a -> a both = either id id -eitherResponse :: Monad m => UTCTime -> HashMap Text Text -> [Text] -> Request -> Webmachine m Response -> m (Response, Trace)-eitherResponse reqDate reqParams dispatched req resource = do-    (e, trace) <- runWebmachine reqDate reqParams dispatched req resource+eitherResponse :: Monad m => RequestReader -> ResponseState -> Webmachine m Response -> m (Response, Trace)+eitherResponse requestReader startingState w = do+    (e, trace) <- runWebmachine requestReader startingState w     return (both e, trace)  -- | Map both the return value and wrapped computation @m@.-mapWebmachine :: ( m1 (Either Response a1, ResponseState, Trace)-                -> m2 (Either Response a2, ResponseState, Trace) )+mapWebmachine :: ( m1 (Either Response a1, ResponseState)+                -> m2 (Either Response a2, ResponseState))               -> Webmachine m1 a1 -> Webmachine m2 a2-mapWebmachine f =  Webmachine . (mapEitherT $ mapRWST f) . getWebmachine+mapWebmachine f =  Webmachine . (mapRST f) . getWebmachine -runWebmachine :: Monad m => UTCTime -> HashMap Text Text -> [Text] -> Request -> Webmachine m a -> m (Either (Response) a, Trace)-runWebmachine reqDate reqParams dispatched req w = do-    let startingState = ResponseState [] Empty reqParams dispatched-        requestReader = RequestReader reqDate req-    (e, _, t) <- runRWST (runEitherT (getWebmachine w)) requestReader startingState-    return (e, t)+runWebmachine :: Monad m => RequestReader -> ResponseState -> Webmachine m a -> m (Either Response a, Trace)+runWebmachine requestReader startingState w = do+    (e, s) <- runRST (getWebmachine w) requestReader startingState+    return (e, reverse $ decisionTrace s)