packages feed

airship (empty) → 0.1.0.0

raw patch · 16 files changed

+1776/−0 lines, 16 filesdep +airshipdep +attoparsecdep +basesetup-changed

Dependencies added: airship, attoparsec, base, blaze-builder, bytestring, case-insensitive, either, http-date, http-media, http-types, lifted-base, monad-control, mtl, network, old-locale, random, tasty, tasty-hunit, tasty-quickcheck, text, time, transformers, transformers-base, unordered-containers, wai, warp

Files

+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2015 Helium Systems, Inc.++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ airship.cabal view
@@ -0,0 +1,87 @@+name:                   airship+synopsis:               A Webmachine-inspired HTTP library+description:            A Webmachine-inspired HTTP library+version:                0.1.0.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++source-repository head+    type: git+    location: https://github.com/helium/airship.git++library+  default-language:    Haskell2010+  hs-source-dirs: src+  ghc-options:  -Wall+  exposed-modules:   Airship+                   , Airship.Headers+                   , Airship.Helpers+                   , Airship.Types+                   , Airship.Resource+                   , Airship.Route++  other-modules:     Airship.Internal.Route+                   , Airship.Internal.Date+                   , Airship.Internal.Decision+                   , Airship.Internal.Helpers+                   , Airship.Internal.Parsers++  build-depends:        attoparsec+                      , base >= 4.7 && < 5+                      , blaze-builder == 0.3.*+                      , bytestring+                      , case-insensitive+                      , either == 4.3.*+                      , http-date+                      , http-media+                      , http-types >= 0.7+                      , lifted-base == 0.2.*+                      , monad-control >= 1.0+                      , mtl == 2.2.*+                      , network+                      , old-locale+                      , random+                      , text+                      , time+                      , transformers == 0.4.2.*+                      , transformers-base == 0.4.3.*+                      , unordered-containers+                      , wai == 3.0.*++executable airship-example+  main-is:              Main.hs+  hs-source-dirs: bin+  ghc-options:  -Wall+  default-language:    Haskell2010+  build-depends:        base >=4.7 && < 5+                      , airship+                      , blaze-builder == 0.3.*+                      , bytestring+                      , http-types >= 0.7+                      , mtl == 2.2.*+                      , text+                      , time+                      , unordered-containers+                      , wai == 3.0.2.*+                      , warp == 3.0.5.*++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.*+               , tasty-quickcheck == 0.8.3.*+               , tasty-hunit        >= 0.9.1 && < 0.10+               , transformers == 0.4.2.*+               , wai == 3.0.*+  ghc-options: -Wall -Werror -threaded -O1 -fno-warn-orphans
+ bin/Main.hs view
@@ -0,0 +1,125 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}++module Main where++import           Airship++import           Blaze.ByteString.Builder.Html.Utf8 (fromHtmlEscapedText)++#if __GLASGOW_HASKELL__ < 710+import           Control.Applicative ((<$>))+#endif+import           Control.Concurrent.MVar+import           Control.Monad.Trans (liftIO)++import           Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HM+import qualified Data.ByteString.Lazy as LB+import           Data.ByteString.Lazy.Char8 (unpack)+import           Data.Maybe (fromMaybe)+import           Data.Monoid ((<>))+import           Data.Text(Text, pack)+import           Data.Time.Clock++import qualified Network.HTTP.Types as HTTP+import           Network.Wai.Handler.Warp ( runSettings+                                          , defaultSettings+                                          , setPort+                                          , setHost+                                          )++-- ***************************************************************************+-- Helpers+-- ***************************************************************************++getBody :: Handler s IO LB.ByteString+getBody = do+    req <- request+    liftIO (entireRequestBody req)++readBody :: Handler s IO Integer+readBody = read . unpack <$> getBody++routingParam :: Text -> Handler s m Text+routingParam t = do+    p <- params+    return (p HM.! t)++newtype State = State { _getState :: MVar (HashMap Text Integer) }++resourceWithBody :: Text -> Resource State IO+resourceWithBody t = defaultResource { contentTypesProvided = return [("text/plain", return (escapedResponse t))]+                                     , lastModified = Just <$> liftIO getCurrentTime+                                     , generateETag = return $ Just $ Strong "abc123"+                                     }++accountResource :: Resource State IO+accountResource = defaultResource+    { allowedMethods = return [ HTTP.methodGet+                              , HTTP.methodHead+                              , HTTP.methodPost+                              , HTTP.methodPut+                              ]+    , knownContentType = contentTypeMatches ["text/plain"]++    , contentTypesProvided = do+        let textAction = do+                s <- getState+                m <- liftIO (readMVar (_getState s))+                accountNameM <- HM.lookup "name" <$> params+                let val = fromMaybe 0 (accountNameM >>= flip HM.lookup m)+                return $ ResponseBuilder (fromHtmlEscapedText+                                                (pack (show val) <> "\n"))+        return [("text/plain", textAction)]++    , allowMissingPost = return False++    , lastModified = Just <$> liftIO getCurrentTime++    , resourceExists = do+        accountName <- routingParam "name"+        s <- getState+        m <- liftIO (readMVar (_getState s))+        return $ HM.member accountName m++    -- POST'ing to this resource adds the integer to the current value+    , processPost = return (PostProcess $ do+        (val, accountName, s) <- postPutStates+        liftIO (modifyMVar_ (_getState s) (return . HM.insertWith (+) accountName val))+        return ()+        )++    , contentTypesAccepted = return [("text/plain", do+        (val, accountName, s) <- postPutStates+        liftIO (modifyMVar_ (_getState s) (return . HM.insert accountName val))+        return ()+    )]+    }++postPutStates :: Handler State IO (Integer, Text, State)+postPutStates = do+    val <- readBody+    accountName <- routingParam "name"+    s <- getState+    return (val, accountName, s)++myRoutes :: RoutingSpec State IO ()+myRoutes = do+    root                        #> resourceWithBody "Just the root resource"+    "account" </> var "name"    #> accountResource++main :: IO ()+main = do+    let port = 3000+        host = "127.0.0.1"+        settings = setPort port (setHost host defaultSettings)+        routes = myRoutes+        resource404 = defaultResource++    mvar <- newMVar HM.empty+    let s = State mvar+    putStrLn "Listening on port 3000"+    runSettings settings (resourceToWai routes resource404 s)
+ src/Airship.hs view
@@ -0,0 +1,13 @@+module Airship+  ( module Airship.Resource+  , module Airship.Headers+  , module Airship.Helpers+  , module Airship.Route+  , module Airship.Types+  ) where++import           Airship.Headers+import           Airship.Helpers+import           Airship.Resource+import           Airship.Route+import           Airship.Types
+ src/Airship/Headers.hs view
@@ -0,0 +1,19 @@+{-# LANGUAGE RankNTypes #-}++module Airship.Headers+    ( addResponseHeader+    , modifyResponseHeaders+    ) where++import Airship.Types (Handler, ResponseState(..))+import Control.Monad.State.Class (modify)+import Network.HTTP.Types (ResponseHeaders, Header)++-- | Applies the given function to the 'ResponseHeaders' present in this 'Handler''s 'ResponseState'.+modifyResponseHeaders :: (ResponseHeaders -> ResponseHeaders) -> Handler s m ()+modifyResponseHeaders f = modify updateHeaders+    where updateHeaders rs@ResponseState{stateHeaders = h} = rs { stateHeaders = f h }++-- | Adds a given 'Header' to this handler's 'ResponseState'.+addResponseHeader :: Header -> Handler s m ()+addResponseHeader h = modifyResponseHeaders (h :)
+ src/Airship/Helpers.hs view
@@ -0,0 +1,7 @@+module Airship.Helpers+    ( contentTypeMatches+    , fromWaiRequest+    , resourceToWai+    ) where++import           Airship.Internal.Helpers
+ src/Airship/Internal/Date.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE CPP #-}++module Airship.Internal.Date+    ( parseRfc1123Date+    , utcTimeToRfc1123) where++#if __GLASGOW_HASKELL__ < 710+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 qualified Network.HTTP.Date as HD++httpDateToUtc :: HD.HTTPDate -> UTCTime+httpDateToUtc h = UTCTime days diffTime+    where days = fromGregorian (fromIntegral $ HD.hdYear h) (HD.hdMonth h) (HD.hdDay h)+          diffTime = secondsToDiffTime seconds+          seconds = fromIntegral $ hourS + minS + HD.hdSecond h+          hourS = HD.hdHour h * 60 * 60+          minS = HD.hdMinute h * 60++parseRfc1123Date :: ByteString -> Maybe UTCTime+parseRfc1123Date b = httpDateToUtc <$> HD.parseHTTPDate b++utcTimeToRfc1123 :: UTCTime -> ByteString+utcTimeToRfc1123 utc = pack $ formatTime defaultTimeLocale "%a, %d %b %Y %H:%M:%S GMT" utc
+ src/Airship/Internal/Decision.hs view
@@ -0,0 +1,723 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ImpredicativeTypes #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}++module Airship.Internal.Decision+    ( flow+    ) where++import           Airship.Internal.Date (parseRfc1123Date, utcTimeToRfc1123)+import           Airship.Headers (addResponseHeader)+import           Airship.Types ( Response(..)+                               , ResponseBody(..)+                               , Webmachine+                               , etagToByteString+                               , getResponseBody+                               , getResponseHeaders+                               , halt+                               , pathInfo+                               , putResponseBody+                               , request+                               , requestHeaders+                               , requestMethod+                               , requestTime )++import           Airship.Resource(Resource(..), PostResponse(..))+import           Airship.Internal.Parsers (parseEtagList)+#if __GLASGOW_HASKELL__ < 710+import           Control.Applicative ((<$>))+#endif+import           Control.Monad (when)+import           Control.Monad.Trans (lift)+import           Control.Monad.Trans.State.Strict (StateT(..), evalStateT,+                                                   get, modify)+import           Control.Monad.Writer.Class (tell)++import           Data.ByteString (ByteString)+import           Blaze.ByteString.Builder (toByteString)+import           Data.Maybe (fromJust, isJust)+import           Data.Text (Text)+import           Data.Time.Clock (UTCTime)++import           Network.HTTP.Media+import qualified Network.HTTP.Types as HTTP++------------------------------------------------------------------------------+-- HTTP Headers+-- These are headers not defined for us already in+-- Network.HTTP.Types+------------------------------------------------------------------------------++hAcceptCharset :: HTTP.HeaderName+hAcceptCharset = "Accept-Charset"++hAcceptEncoding :: HTTP.HeaderName+hAcceptEncoding = "Accept-Encoding"++hIfMatch :: HTTP.HeaderName+hIfMatch = "If-Match"++hIfUnmodifiedSince :: HTTP.HeaderName+hIfUnmodifiedSince = "If-Unmodified-Since"++hIfNoneMatch :: HTTP.HeaderName+hIfNoneMatch = "If-None-Match"++hIfModifiedSince :: HTTP.HeaderName+hIfModifiedSince = "If-Modified-Since"++------------------------------------------------------------------------------+-- FlowState: StateT used for recording information as we walk the decision+-- tree+------------------------------------------------------------------------------++data FlowState s m = FlowState+    { _contentType :: Maybe (MediaType, Webmachine s m (ResponseBody m)) }++type FlowStateT s m a = StateT (FlowState s m) (Webmachine s m) a++type Flow s m = Resource s m -> FlowStateT s m (Response m)++initFlowState :: FlowState s m+initFlowState = FlowState Nothing++flow :: Monad m => Resource s m -> Webmachine s m (Response m)+flow r = evalStateT (b13 r) initFlowState++trace :: Monad m => Text -> FlowStateT s m ()+trace t = lift $ tell [t]++------------------------------------------------------------------------------+-- Decision Helpers+------------------------------------------------------------------------------++negotiateContentTypesAccepted :: Monad m => Resource s m -> FlowStateT s m ()+negotiateContentTypesAccepted Resource{..} = do+    req <- lift request+    accepted <- lift contentTypesAccepted+    let reqHeaders = requestHeaders req+        result = do+            cType <- lookup HTTP.hContentType reqHeaders+            mapContentMedia accepted cType+    case result of+        (Just process) -> lift process+        Nothing -> lift $ halt HTTP.status415++appendRequestPath :: Monad m => [Text] -> Webmachine s m ByteString+appendRequestPath ts = do+    currentPath <- pathInfo <$> request+    return $ toByteString (HTTP.encodePathSegments (currentPath ++ ts))++requestHeaderDate :: Monad m => HTTP.HeaderName ->+                                Webmachine s m (Maybe UTCTime)+requestHeaderDate headerName = do+    req <- request+    let reqHeaders = requestHeaders req+        dateHeader = lookup headerName reqHeaders+        parsedDate = dateHeader >>= parseRfc1123Date+    return parsedDate++writeCacheTags :: Monad m => Resource s m -> FlowStateT s m ()+writeCacheTags Resource{..} = lift $ do+    etag <- generateETag+    case etag of+       Nothing -> return ()+       Just t  -> addResponseHeader ("ETag", etagToByteString t)+    modified <- lastModified+    case modified of+       Nothing -> return ()+       Just d  -> addResponseHeader ("Last-Modified", utcTimeToRfc1123 d)++------------------------------------------------------------------------------+-- Type definitions for all decision nodes+------------------------------------------------------------------------------++b13, b12, b11, b10, b09, b08, b07, b06, b05, b04, b03 :: Monad m => Flow s m+c04, c03 :: Monad m => Flow s m+d05, d04 :: Monad m => Flow s m+e06, e05 :: Monad m => Flow s m+f07, f06 :: Monad m => Flow s m+g11, g09, g08, g07 :: Monad m => Flow s m+h12, h11, h10, h07 :: Monad m => Flow s m+i13, i12, i07, i04 :: Monad m => Flow s m+j18 :: Monad m => Flow s m+k13, k07, k05 :: Monad m => Flow s m+l17, l15, l14, l13, l07, l05 :: Monad m => Flow s m+m20, m16, m07, m05 :: Monad m => Flow s m+n16, n11, n05 :: Monad m => Flow s m+o20, o18, o16, o14 :: Monad m => Flow s m+p11, p03 :: Monad m => Flow s m++------------------------------------------------------------------------------+-- B column+------------------------------------------------------------------------------++b13 r@Resource{..} = do+    trace "b13"+    available <- lift serviceAvailable+    if available+        then b12 r+        else lift $ halt HTTP.status503++b12 r@Resource{..} = do+    trace "b12"+    -- known method+    req <- lift request+    let knownMethods = [ HTTP.methodGet+                       , HTTP.methodPost+                       , HTTP.methodHead+                       , HTTP.methodPut+                       , HTTP.methodDelete+                       , HTTP.methodTrace+                       , HTTP.methodConnect+                       , HTTP.methodOptions+                       , HTTP.methodPatch+                       ]+    if requestMethod req `elem` knownMethods+        then b11 r+        else lift $ halt HTTP.status501++b11 r@Resource{..} = do+    trace "b11"+    long <- lift uriTooLong+    if long+        then lift $ halt HTTP.status414+        else b10 r++b10 r@Resource{..} = do+    trace "b10"+    req <- lift request+    allowed <- lift allowedMethods+    if requestMethod req `elem` allowed+        then b09 r+        else lift $ halt HTTP.status405++b09 r@Resource{..} = do+    trace "b09"+    malformed <- lift malformedRequest+    if malformed+        then lift $ halt HTTP.status400+        else b08 r++b08 r@Resource{..} = do+    trace "b08"+    authorized <- lift isAuthorized+    if authorized+        then b07 r+        else lift $ halt HTTP.status401++b07 r@Resource{..} = do+    trace "b07"+    forbid <- lift forbidden+    if forbid+        then lift $ halt HTTP.status403+        else b06 r++b06 r@Resource{..} = do+    trace "b06"+    validC <- lift validContentHeaders+    if validC+        then b05 r+        else lift $ halt HTTP.status501++b05 r@Resource{..} = do+    trace "b05"+    known <- lift knownContentType+    if known+        then b04 r+        else lift $ halt HTTP.status415++b04 r@Resource{..} = do+    trace "b04"+    large <- lift entityTooLarge+    if large+        then lift $ halt HTTP.status413+        else b03 r++b03 r@Resource{..} = do+    trace "b03"+    req <- lift request+    if requestMethod req == HTTP.methodOptions+        then lift $ halt HTTP.status200+        else c03 r++------------------------------------------------------------------------------+-- C column+------------------------------------------------------------------------------++c04 r@Resource{..} = do+    trace "c04"+    req <- lift request+    provided <- lift contentTypesProvided+    let reqHeaders = requestHeaders req+        result = do+            acceptStr <- lookup HTTP.hAccept reqHeaders+            (acceptTyp, resource) <- mapAcceptMedia provided' acceptStr+            Just (acceptTyp, resource)+            where+                -- this is so that in addition to getting back the resource+                -- that we match, we also return the content-type provided+                -- by that resource.+                provided' = map dupContentType provided+                dupContentType (a, b) = (a, (a, b))++    case result of+      Nothing -> lift $ halt HTTP.status406+      Just res -> do+        modify (\fs -> fs { _contentType = Just res })+        d04 r++c03 r@Resource{..} = do+    trace "c03"+    req <- lift request+    let reqHeaders = requestHeaders req+    case lookup HTTP.hAccept reqHeaders of+        (Just _h) ->+            c04 r+        Nothing ->+            d04 r++------------------------------------------------------------------------------+-- D column+------------------------------------------------------------------------------++d05 r@Resource{..} = do+    trace "d05"+    langAvailable <- lift languageAvailable+    if langAvailable+        then e05 r+        else lift $ halt HTTP.status406++d04 r@Resource{..} = do+    trace "d04"+    req <- lift request+    let reqHeaders = requestHeaders req+    case lookup HTTP.hAcceptLanguage reqHeaders of+        (Just _h) ->+            d05 r+        Nothing ->+            e05 r++------------------------------------------------------------------------------+-- E column+------------------------------------------------------------------------------++e06 r@Resource{..} = do+    trace "e06"+    -- TODO: charset negotiation+    f06 r++e05 r@Resource{..} = do+    trace "e05"+    req <- lift request+    let reqHeaders = requestHeaders req+    case lookup hAcceptCharset reqHeaders of+        (Just _h) ->+            e06 r+        Nothing ->+            f06 r++------------------------------------------------------------------------------+-- F column+------------------------------------------------------------------------------++f07 r@Resource{..} = do+    trace "f07"+    -- TODO: encoding negotiation+    g07 r++f06 r@Resource{..} = do+    trace "f06"+    req <- lift request+    let reqHeaders = requestHeaders req+    case lookup hAcceptEncoding reqHeaders of+        (Just _h) ->+            f07 r+        Nothing ->+            g07 r++------------------------------------------------------------------------------+-- G column+------------------------------------------------------------------------------++g11 r@Resource{..} = do+    trace "g11"+    req <- lift request+    let reqHeaders = requestHeaders req+        ifMatch = fromJust (lookup hIfMatch reqHeaders)+        etags = parseEtagList ifMatch+    if null etags+        then lift $ halt HTTP.status412+        else h10 r++g09 r@Resource{..} = do+    trace "g09"+    req <- lift request+    let reqHeaders = requestHeaders req+    case fromJust (lookup hIfMatch reqHeaders) of+        -- TODO: should we be stripping whitespace here?+        "*" ->+            h10 r+        _ ->+            g11 r++g08 r@Resource{..} = do+    trace "g07"+    req <- lift request+    let reqHeaders = requestHeaders req+    case lookup hIfMatch reqHeaders of+        (Just _h) ->+            g09 r+        Nothing ->+            h10 r++g07 r@Resource{..} = do+    trace "g07"+    -- TODO: set Vary headers+    exists <- lift resourceExists+    if exists+        then g08 r+        else h07 r++------------------------------------------------------------------------------+-- H column+------------------------------------------------------------------------------++h12 r@Resource{..} = do+    trace "h12"+    modified <- lift lastModified+    parsedDate <- lift $ requestHeaderDate hIfUnmodifiedSince+    let maybeGreater = do+            lastM <- modified+            headerDate <- parsedDate+            return (lastM > headerDate)+    if maybeGreater == Just True+        then lift $ halt HTTP.status412+        else i12 r++h11 r@Resource{..} = do+    trace "h11"+    parsedDate <- lift $ requestHeaderDate hIfUnmodifiedSince+    if isJust parsedDate+        then h12 r+        else i12 r++h10 r@Resource{..} = do+    trace "h10"+    req <- lift request+    let reqHeaders = requestHeaders req+    case lookup hIfUnmodifiedSince reqHeaders of+        (Just _h) ->+            h11 r+        Nothing ->+            i12 r++h07 r@Resource {..} = do+    trace "h07"+    req <- lift request+    let reqHeaders = requestHeaders req+    case lookup hIfMatch reqHeaders of+        -- TODO: should we be stripping whitespace here?+        (Just "*") ->+            lift $ halt HTTP.status412+        _ ->+            i07 r++------------------------------------------------------------------------------+-- I column+------------------------------------------------------------------------------++i13 r@Resource{..} = do+    trace "i13"+    req <- lift request+    let reqHeaders = requestHeaders req+    case fromJust (lookup hIfNoneMatch reqHeaders) of+        -- TODO: should we be stripping whitespace here?+        "*" ->+            j18 r+        _ ->+            k13 r++i12 r@Resource{..} = do+    trace "i12"+    req <- lift request+    let reqHeaders = requestHeaders req+    case lookup hIfNoneMatch reqHeaders of+        (Just _h) ->+            i13 r+        Nothing ->+            l13 r++i07 r = do+    trace "i07"+    req <- lift request+    if requestMethod req == HTTP.methodPut+        then i04 r+        else k07 r++i04 r@Resource{..} = do+    trace "i04"+    moved <- lift movedPermanently+    case moved of+        (Just loc) -> do+            lift $ addResponseHeader ("Location", loc)+            lift $ halt HTTP.status301+        Nothing ->+            p03 r++------------------------------------------------------------------------------+-- J column+------------------------------------------------------------------------------++j18 _ = do+    trace "j18"+    req <- lift request+    let getOrHead = [ HTTP.methodGet+                    , HTTP.methodHead+                    ]+    if requestMethod req `elem` getOrHead+        then lift $ halt HTTP.status304+        else lift $ halt HTTP.status412++------------------------------------------------------------------------------+-- K column+------------------------------------------------------------------------------++k13 r@Resource{..} = do+    trace "k13"+    req <- lift request+    let reqHeaders = requestHeaders req+        ifNoneMatch = fromJust (lookup hIfNoneMatch reqHeaders)+        etags = parseEtagList ifNoneMatch+    if null etags+        then j18 r+        else l13 r++k07 r@Resource{..} = do+    trace "k07"+    prevExisted <- lift previouslyExisted+    if prevExisted+        then k05 r+        else l07 r++k05 r@Resource{..} = do+    trace "k05"+    moved <- lift movedPermanently+    case moved of+        (Just loc) -> do+            lift $ addResponseHeader ("Location", loc)+            lift $ halt HTTP.status301+        Nothing ->+            l05 r++------------------------------------------------------------------------------+-- L column+------------------------------------------------------------------------------++l17 r@Resource{..} = do+    trace "l17"+    parsedDate <- lift $ requestHeaderDate hIfModifiedSince+    modified <- lift lastModified+    let maybeGreater = do+            lastM <- modified+            ifModifiedSince <- parsedDate+            return (lastM > ifModifiedSince)+    if maybeGreater == Just True+        then m16 r+        else lift $ halt HTTP.status304++l15 r@Resource{..} = do+    trace "l15"+    parsedDate <- lift $ requestHeaderDate hIfModifiedSince+    now <- lift requestTime+    let maybeGreater = (> now) <$> parsedDate+    if maybeGreater == Just True+        then m16 r+        else l17 r++l14 r@Resource{..} = do+    trace "l14"+    req <- lift request+    let reqHeaders = requestHeaders req+        dateHeader = lookup hIfModifiedSince reqHeaders+        validDate = isJust (dateHeader >>= parseRfc1123Date)+    if validDate+        then l15 r+        else m16 r++l13 r@Resource{..} = do+    trace "l13"+    req <- lift request+    let reqHeaders = requestHeaders req+    case lookup hIfModifiedSince reqHeaders of+        (Just _h) ->+            l14 r+        Nothing ->+            m16 r++l07 r = do+    trace "l07"+    req <- lift request+    if requestMethod req == HTTP.methodPost+        then m07 r+        else lift $ halt HTTP.status404++l05 r@Resource{..} = do+    trace "l05"+    moved <- lift movedTemporarily+    case moved of+        (Just loc) -> do+            lift $ addResponseHeader ("Location", loc)+            lift $ halt HTTP.status307+        Nothing ->+            m05 r++------------------------------------------------------------------------------+-- M column+------------------------------------------------------------------------------++m20 r@Resource{..} = do+    trace "m20"+    deleteAccepted <- lift deleteResource+    if deleteAccepted+        then do+            completed <- lift deleteCompleted+            if completed+                then o20 r+                else lift $ halt HTTP.status202+        else lift $ halt HTTP.status500++m16 r = do+    trace "m16"+    req <- lift request+    if requestMethod req == HTTP.methodDelete+        then m20 r+        else n16 r++m07 r@Resource{..} = do+    trace "m07"+    allowMissing <- lift allowMissingPost+    if allowMissing+        then n11 r+        else lift $ halt HTTP.status404++m05 r = do+    trace "m05"+    req <- lift request+    if requestMethod req == HTTP.methodPost+        then n05 r+        else lift $ halt HTTP.status410++------------------------------------------------------------------------------+-- N column+------------------------------------------------------------------------------++n16 r = do+    trace "n16"+    req <- lift request+    if requestMethod req == HTTP.methodPost+        then n11 r+        else o16 r++n11 r@Resource{..} = trace "n11" >> lift processPost >>= flip processPostAction r++create :: Monad m => [Text] -> Resource s m -> FlowStateT s m ()+create ts r = do+    loc <- lift (appendRequestPath ts)+    lift (addResponseHeader ("Location", loc))+    negotiateContentTypesAccepted r++processPostAction :: Monad m => PostResponse s m -> Flow s m+processPostAction (PostCreate ts) r = do+    create ts r+    p11 r+processPostAction (PostCreateRedirect ts) r = do+    create ts r+    lift $ halt HTTP.status303+processPostAction (PostProcess p) r =+    lift p >> p11 r+processPostAction (PostProcessRedirect ts) _r = do+    locBs <- lift ts+    lift $ addResponseHeader ("Location", locBs)+    lift $ halt HTTP.status303++n05 r@Resource{..} = do+    trace "n05"+    allow <- lift allowMissingPost+    if allow+        then n11 r+        else lift $ halt HTTP.status410++------------------------------------------------------------------------------+-- O column+------------------------------------------------------------------------------++o20 r = do+    trace "o20"+    body <- lift getResponseBody+    -- ResponseBody is a little tough to make an instance of 'Eq',+    -- so we just use a pattern match+    case body of+        Empty   -> lift $ halt HTTP.status204+        _       -> o18 r++o18 r@Resource{..} = do+    trace "o18"+    multiple <- lift multipleChoices+    if multiple+        then lift $ halt HTTP.status300+        else do+            -- TODO: set etag, expiration, etc. headers+            req <- lift request+            let getOrHead = [ HTTP.methodGet+                            , HTTP.methodHead+                            ]+            when (requestMethod req `elem` getOrHead) $ do+                m <- _contentType <$> get+                (cType, body) <- case m of+                    Nothing -> do+                        provided <- lift contentTypesProvided+                        return (head provided)+                    Just (cType, body) ->+                        return (cType, body)+                b <- lift body+                lift $ putResponseBody b+                lift $ addResponseHeader ("Content-Type", renderHeader cType)+            writeCacheTags r+            lift $ halt HTTP.status200++o16 r = do+    trace "o16"+    req <- lift request+    if requestMethod req == HTTP.methodPut+        then o14 r+        else o18 r++o14 r@Resource{..} = do+    trace "o14"+    conflict <- lift isConflict+    if conflict+        then lift $ halt HTTP.status409+        else negotiateContentTypesAccepted r >> p11 r++------------------------------------------------------------------------------+-- P column+------------------------------------------------------------------------------++p11 r = do+    trace "p11"+    headers <- lift getResponseHeaders+    case lookup HTTP.hLocation headers of+        (Just _) ->+            lift $ halt HTTP.status201+        _ ->+            o20 r++p03 r@Resource{..} = do+    trace "p03"+    conflict <- lift isConflict+    if conflict+        then lift $ halt HTTP.status409+        else negotiateContentTypesAccepted r >> p11 r
+ src/Airship/Internal/Helpers.hs view
@@ -0,0 +1,97 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes        #-}+{-# LANGUAGE RecordWildCards   #-}++module Airship.Internal.Helpers where++#if __GLASGOW_HASKELL__ < 710+import           Control.Applicative+#endif+import           Data.ByteString     (ByteString)+import           Data.Maybe+#if __GLASGOW_HASKELL__ < 710+import           Data.Monoid+#endif+import           Data.Text           (Text, intercalate)+import           Data.Text.Encoding+import           Data.Time           (getCurrentTime)+import           Network.HTTP.Media+import qualified Network.HTTP.Types  as HTTP+import qualified Network.Wai         as Wai+import           System.Random++import           Airship.Internal.Decision+import           Airship.Resource+import           Airship.Types+import           Airship.Internal.Route+++-- | Returns @True@ if the request's @Content-Type@ header is one of the+-- provided media types. If the @Content-Type@ header is not present,+-- this function will return True.+contentTypeMatches :: [MediaType] -> Handler s m Bool+contentTypeMatches validTypes = do+    headers <- requestHeaders <$> request+    let cType = lookup HTTP.hContentType headers+    return $ case cType of+        Nothing -> True+        Just t  -> isJust $ matchAccept validTypes t++-- | Construct an Airship 'Request' from a WAI request.+fromWaiRequest :: Wai.Request -> Request IO+fromWaiRequest req = Request+    { requestMethod = Wai.requestMethod req+    , httpVersion = Wai.httpVersion req+    , rawPathInfo = Wai.rawPathInfo req+    , rawQueryString = Wai.rawQueryString req+    , requestHeaders = Wai.requestHeaders req+    , isSecure = Wai.isSecure req+    , remoteHost = Wai.remoteHost req+    , pathInfo = Wai.pathInfo req+    , queryString = Wai.queryString req+    , requestBody = Wai.requestBody req+    , requestBodyLength = Wai.requestBodyLength req+    , requestHeaderHost = Wai.requestHeaderHost req+    , requestHeaderRange = Wai.requestHeaderRange req+    }++toWaiResponse :: Response IO -> ByteString -> ByteString -> Wai.Response+toWaiResponse Response{..} trace quip =+    Wai.responseBuilder _responseStatus headers (fromBody _responseBody)+        where   fromBody (ResponseBuilder b)    = b+                fromBody _                      = mempty+                headers                         = _responseHeaders +++                                                  [("Airship-Trace", trace)] +++                                                  [("Airship-Quip", quip)]++-- | Given a 'RoutingSpec', a 404 resource, and a user state @s@, construct a WAI 'Application'.+resourceToWai :: RoutingSpec s IO () -> Resource s IO -> s -> Wai.Application+resourceToWai routes resource404 s req respond = do+    let routeMapping = runRouter routes+        pInfo = Wai.pathInfo req+        airshipReq = fromWaiRequest req+        (resource, params') = route routeMapping pInfo resource404+    nowTime <- getCurrentTime+    quip <- getQuip+    (response, trace) <- eitherResponse nowTime params' airshipReq s (flow resource)+    let traceHeaderValue = traceHeader trace+    respond (toWaiResponse response traceHeaderValue quip)++getQuip :: IO ByteString+getQuip = do+  idx <- randomRIO (0, length quips - 1)+  return $ quips !! idx+  where quips = [ "never breaks eye contact"+                , "blame me if inappropriate"+                , "firm pat on the back"+                , "sharkfed"+                , "$300,000 worth of cows"+                , "RB_GC_GUARD"+                , "evacuation not done in time"+                , "javascript doesn't have integers"+                , "WARNING: ulimit -n is 1024"+                ]++traceHeader :: [Text] -> ByteString+traceHeader = encodeUtf8 . intercalate ","
+ src/Airship/Internal/Parsers.hs view
@@ -0,0 +1,57 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}++module Airship.Internal.Parsers+    ( parseEtag+    , parseEtagList+    ) where++import Prelude hiding (takeWhile)++#if __GLASGOW_HASKELL__ < 710+import Control.Applicative ((<$>), (<|>), (*>), (<*))+#else+import Control.Applicative ((<|>))+#endif+import Data.Attoparsec.ByteString.Char8 (Parser, parseOnly, sepBy', char,+                                         string, takeWhile,+                                         takeWhile1, inClass, endOfInput)+import Data.ByteString (ByteString)++import Airship.Types (ETag(..))++comma :: Parser Char+comma = char ','++doubleQuote :: Char+doubleQuote = '"'++insideQuotes :: Parser a -> Parser a+insideQuotes a = char doubleQuote *> a <* char doubleQuote++optionalWhitespace :: Parser ByteString+optionalWhitespace = takeWhile (inClass " \t")++insideWhitespace :: Parser a -> Parser a+insideWhitespace a = optionalWhitespace *> a <* optionalWhitespace++weakETag :: Parser ETag+weakETag = Weak <$> (string "W/" *> insideQuotes rest)+    where rest = takeWhile1 (/= doubleQuote)++strongETag :: Parser ETag+strongETag = insideQuotes strong+    where strong = Strong <$> takeWhile1 (/= doubleQuote)++eTag :: Parser ETag+eTag = insideWhitespace (weakETag <|> strongETag)++parseEtag :: ByteString -> Maybe ETag+parseEtag input = either (const Nothing) Just (parseOnly eTagToEnd input)+    where eTagToEnd = eTag <* endOfInput++-- | Parse a list of Etags, returning an empty list if parsing fails+parseEtagList :: ByteString -> [ETag]+parseEtagList input = either (const []) id parseResult+    where parseResult = parseOnly eTagList input+          eTagList = (eTag `sepBy'` comma) <* endOfInput
+ src/Airship/Internal/Route.hs view
@@ -0,0 +1,106 @@+{-# OPTIONS_HADDOCK hide #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}++module Airship.Internal.Route where++import Airship.Resource++import Data.Monoid+import Data.Foldable (foldr')+import Data.Text (Text)+import Data.HashMap.Strict (HashMap, insert)++#if __GLASGOW_HASKELL__ < 710+import           Control.Applicative+#endif+import Control.Monad.Writer (Writer, execWriter)+import Control.Monad.Writer.Class (MonadWriter)++import Data.String (IsString, fromString)++-- | 'Route's represent chunks of text used to match over URLs.+-- You match hardcoded paths with string literals (and the @-XOverloadedStrings@ extension),+-- named variables with the 'var' combinator, and wildcards with 'star'.+newtype Route = Route { getRoute :: [BoundOrUnbound] } deriving (Show, Monoid)++data BoundOrUnbound = Bound Text+                    | Var Text+                    | RestUnbound deriving (Show)++instance IsString Route where+    fromString s = Route [Bound (fromString s)]++runRouter :: RoutingSpec s m a -> [(Route, Resource s m)]+runRouter routes = execWriter (getRouter routes)++-- | @a '</>' b@ separates the path components @a@ and @b@ with a slash.+-- This is actually just a synonym for 'mappend'.+(</>) :: Route -> Route -> Route+(</>) = (<>)++-- | Represents the root resource (@/@). This should usually be the first path declared in a 'RoutingSpec'.+root :: Route+root = Route []++-- | Captures a named in a route and adds it to the 'routingParams' hashmap under the provided 'Text' value. For example,+--+-- @+--    "blog" '</>' 'var' "date" '</>' 'var' "post"+-- @+--+-- will capture all URLs of the form @\/blog\/$date\/$post@, and add @date@ and @post@ to the 'routingParams'+-- contained within the resource this route maps to.+var :: Text -> Route+var t = Route [Var t]++-- | Captures a wildcard route. For example,+--+-- @+--    "emcees" '</>' star+-- @+--+-- will match @\/emcees@, @\/emcees/biggie@, @\/emcees\/earl\/vince@, and so on and so forth.+star :: Route+star = Route [RestUnbound]++-- | 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:+--+-- @+--    myRoutes :: RoutingSpec MyState IO ()+--    myRoutes = do+--      root                                 #> myRootResource+--      "blog" '</>' var "date" '</>' var "post" #> blogPostResource+--      "about"                              #> aboutResource+--      "anything" '</>' star                  #> wildcardResource+-- @+--+newtype RoutingSpec s m a = RoutingSpec { getRouter :: Writer [(Route, Resource s m)] a }+    deriving (Functor, Applicative, Monad, MonadWriter [(Route, Resource s m)])+++route :: [(Route, a)] -> [Text] -> a -> (a, HashMap Text Text)+route routes pInfo resource404 = foldr' (matchRoute pInfo) (resource404, mempty) routes++matchRoute :: [Text] -> (Route, a) -> (a, HashMap Text Text) -> (a, HashMap Text Text)+matchRoute paths (rSpec, resource) (previousMatch, previousMap) =+    case matchesRoute paths rSpec of+      Nothing -> (previousMatch, previousMap)+      Just m  -> (resource, m)++matchesRoute :: [Text] -> Route -> Maybe (HashMap Text Text)+matchesRoute paths spec = matchesRoute' paths (getRoute spec) mempty 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' _         (RestUnbound:_) acc     = Just acc+    -- we match a specific string, and it matches this part of the path,+    -- so recur+    matchesRoute' (ph:ptl)  (Bound sh:stt)  acc+        | ph == sh+                                                    = matchesRoute' ptl stt acc+    matchesRoute' (ph:ptl)  (Var t:stt)     acc     = matchesRoute' ptl stt (insert t ph acc)+    matchesRoute' _         _               _acc    = Nothing
+ src/Airship/Resource.hs view
@@ -0,0 +1,141 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ImpredicativeTypes #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Airship.Resource+    ( Resource(..)+    , PostResponse(..)+    , serverError+    , defaultResource+    ) where++import Airship.Types++import Data.Text (Text)+import Data.Time.Clock (UTCTime)+import Data.ByteString (ByteString)++import Network.HTTP.Types+import Network.HTTP.Media (MediaType)++-- | Used when processing POST requests so as to handle the outcome of the binary decisions between+-- handling a POST as a create request and whether to redirect after the POST is done.+-- Credit for this idea goes to Richard Wallace (purefn) on Webcrank.+data PostResponse s m+    = PostCreate [Text] -- ^ Treat this request as a PUT.+    | PostCreateRedirect [Text] -- ^ Treat this request as a PUT, then redirect.+    | PostProcess (Handler s m ()) -- ^ Process as a POST, but don't redirect.+    | PostProcessRedirect (Handler s m ByteString) -- ^ Process and redirect.++data Resource s m =+    Resource { -- | Whether to allow HTTP POSTs to a missing resource. Default: false.+               allowMissingPost         :: Handler s m Bool+               -- | The set of HTTP methods that this resource allows. Default: @GET@ and @HEAD@.+               -- If a request arrives with an HTTP method not included herein, @501 Not Implemented@ is returned.+             , allowedMethods           :: Handler s m [Method]+               -- | An association list of 'MediaType's and 'Handler' actions that correspond to the accepted+               -- @Content-Type@ values that this resource can accept in a request body. If a @Content-Type@ header+               -- is present but not accounted for in 'contentTypesAccepted', processing will halt with @415 Unsupported Media Type@.+               -- Otherwise, the corresponding 'Handler' action will be executed and processing will continue.+             , contentTypesAccepted     :: Handler s m [(MediaType, Handler s m ())]+               -- | An association list of 'MediaType' values and 'ResponseBody' values. The response will be chosen+               -- by looking up the 'MediaType' that most closely matches the @Content-Type@ header. Should there be no match,+               -- processing will halt with @406 Not Acceptable@.+             , contentTypesProvided     :: Handler s m [(MediaType, Webmachine s m (ResponseBody m))]+               -- | When a @DELETE@ request is enacted (via a @True@ value returned from 'deleteResource'), a+               -- @False@ value returns a @202 Accepted@ response. Returning @True@ will continue processing,+               -- usually ending up with a @204 No Content@ response. Default: False.+             , deleteCompleted          :: Handler s m Bool+               -- | When processing a @DELETE@ request, a @True@ value allows processing to continue.+               -- Returns @500 Forbidden@ if False. Default: false.+             , deleteResource           :: Handler s m Bool+               -- | Returns @413 Request Entity Too Large@ if true. Default: false.+             , entityTooLarge           :: Handler s m Bool+               -- | Checks if the given request is allowed to access this resource.+               -- Returns @403 Forbidden@ if true. Default: false.+             , forbidden                :: Handler s m Bool+               -- | If this returns a non-'Nothing' 'ETag', its value will be added to every HTTP response+               -- in the @ETag:@ field.+             , generateETag             :: Handler s m (Maybe ETag)+               -- | Checks if this resource has actually implemented a handler for a given HTTP method.+               -- Returns @501 Not Implemented@ if false. Default: true.+             , implemented              :: Handler s m Bool+               -- | Returns @401 Unauthorized@ if false. Default: true.+             , isAuthorized             :: Handler s m Bool+               -- | When processing @PUT@ requests, a @True@ value returned here will halt processing with a @409 Created@.+             , isConflict               :: Handler s m Bool+               -- | Returns @415 Unsupported Media Type@ if false. We recommend you use the 'contentTypeMatches' helper function, which accepts a list of+               -- 'MediaType' values, so as to simplify proper MIME type handling. Default: true.+             , knownContentType         :: Handler s m Bool+               -- | In the presence of an @If-Modified-Since@ header, returning a @Just@ value from 'lastModifed' allows+               -- the server to halt with @304 Not Modified@ if appropriate.+             , lastModified             :: Handler s m (Maybe UTCTime)+               -- | If an @Accept-Language@ value is present in the HTTP request, and this function returns @False@,+               -- processing will halt with @406 Not Acceptable@.+             , languageAvailable        :: Handler s m Bool+               -- | Returns @400 Bad Request@ if true. Default: false.+             , malformedRequest         :: Handler s m Bool+                                        -- wondering if this should be text,+                                        -- or some 'path' type+               -- | When processing a resource for which 'resourceExists' returned @False@, returning a @Just@ value+               -- halts with a @301 Moved Permanently@ response. The contained 'ByteString' will be added to the+               -- HTTP response under the @Location:@ header.+             , movedPermanently         :: Handler s m (Maybe ByteString)+               -- | Like 'movedPermanently', except with a @307 Moved Temporarily@ response.+             , movedTemporarily         :: Handler s m (Maybe ByteString)+               -- | When handling a @PUT@ request, returning @True@ here halts processing with @300 Multiple Choices@. Default: False.+             , multipleChoices          :: Handler s m Bool+               -- | When processing a request for which 'resourceExists' returned @False@, returning @True@ here+               -- allows the 'movedPermanently' and 'movedTemporarily' functions to process the request.+             , previouslyExisted        :: Handler s m Bool+               -- | When handling @POST@ requests, the value returned determines whether to treat the request as a @PUT@,+               -- a @PUT@ and a redirect, or a plain @POST@. See the documentation for 'PostResponse' for more information.+               -- The default implemetation returns a 'PostProcess' with an empty handler.+             , processPost              :: Handler s m (PostResponse s m)+               -- | Does the resource at this path exist?+               -- Returning false from this usually entails a @404 Not Found@ response.+               -- (If 'allowMissingPost' returns @True@ or an @If-Match: *@ header is present, it may not).+             , resourceExists           :: Handler s m Bool+               -- | Returns @503 Service Unavailable@ if false. Default: true.+             , serviceAvailable         :: Handler s m Bool+               -- | Returns @414 Request URI Too Long@ if true. Default: false.+             , uriTooLong               :: Handler s m Bool+               -- | Returns @501 Not Implemented@ if false. Default: true.+             , validContentHeaders      :: Handler s m Bool+             }++-- | A helper function that terminates execution with @500 Internal Server Error@.+serverError :: Handler m s a+serverError = finishWith (Response status500 [] Empty)++-- | The default Airship resource, with "sensible" values filled in for each entry.+-- You construct new resources by extending the default resource with your own handlers.+defaultResource :: Resource s m+defaultResource = Resource { allowMissingPost       = return False+                           , allowedMethods         = return [methodGet, methodHead]+                           , contentTypesAccepted   = return []+                           , contentTypesProvided   = return []+                           , deleteCompleted        = return False+                           , deleteResource         = return False+                           , entityTooLarge         = return False+                           , forbidden              = return False+                           , generateETag           = return Nothing+                           , implemented            = return True+                           , isAuthorized           = return True+                           , isConflict             = return False+                           , knownContentType       = return True+                           , lastModified           = return Nothing+                           , languageAvailable      = return True+                           , malformedRequest       = return False+                           , movedPermanently       = return Nothing+                           , movedTemporarily       = return Nothing+                           , multipleChoices        = return False+                           , previouslyExisted      = return False+                           , processPost            = return (PostProcess (return ()))+                           , resourceExists         = return True+                           , serviceAvailable       = return True+                           , uriTooLong             = return False+                           , validContentHeaders    = return True+                           }
+ src/Airship/Route.hs view
@@ -0,0 +1,12 @@+module Airship.Route+    ( Route+    , RoutingSpec+    , root+    , var+    , star+    , (</>)+    , (#>)+    ) where++import           Airship.Types+import           Airship.Internal.Route
+ src/Airship/Types.hs view
@@ -0,0 +1,280 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++module Airship.Types+    ( ETag(..)+    , Webmachine+    , Handler+    , Request(..)+    , Response(..)+    , ResponseState(..)+    , ResponseBody(..)+    , defaultRequest+    , entireRequestBody+    , etagToByteString+    , eitherResponse+    , escapedResponse+    , runWebmachine+    , request+    , requestTime+    , getState+    , putState+    , modifyState+    , getResponseHeaders+    , getResponseBody+    , params+    , putResponseBody+    , putResponseBS+    , halt+    , finishWith+    , (#>)+    ) where++import Blaze.ByteString.Builder (Builder)+import Blaze.ByteString.Builder.ByteString (fromByteString)+import Blaze.ByteString.Builder.Html.Utf8 (fromHtmlEscapedText)+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as LB+#if __GLASGOW_HASKELL__ < 710+import           Control.Applicative+#endif+import Control.Monad (liftM)+import Control.Monad.Base (MonadBase)+import Control.Monad.IO.Class (MonadIO)+import Control.Monad.Reader.Class (MonadReader, ask)+import Control.Monad.State.Class (MonadState, get, modify)+import Control.Monad.Trans.Class (MonadTrans(..))+import Control.Monad.Trans.Control (MonadBaseControl(..))+import Control.Monad.Trans.Either (EitherT(..), runEitherT, left)+import Control.Monad.Trans.RWS.Strict (RWST(..), runRWST)+import Control.Monad.Writer.Class (MonadWriter, tell)+import Data.ByteString.Char8+import Data.HashMap.Strict (HashMap)+import Data.Monoid ((<>))+import Data.Text (Text)+import Data.Time.Clock (UTCTime)++import Network.Socket (SockAddr(..))+import qualified Network.HTTP.Types as HTTP+import Network.HTTP.Types ( ResponseHeaders+                          , RequestHeaders+                          , Query+                          , Status+                          , Method+                          , HttpVersion )++import qualified Network.Wai as Wai++-- | Very similar to WAI's @Request@ type, except generalized to an arbitrary monad @m@.+data Request m =+    Request { requestMethod :: Method -- ^ The request method -- @GET@, @POST@, @DELETE@, et cetera.+            , httpVersion :: HttpVersion -- ^ The HTTP version (usually 1.1; hopefully someday 2.0).+            , rawPathInfo :: ByteString -- ^ The unparsed path information yielded from the WAI server. You probably want 'pathInfo'.+            , rawQueryString :: ByteString -- ^ The query string, if any, yielded from the WAI server. You probably want 'queryString'.+            , requestHeaders :: RequestHeaders -- ^ An association list of (headername, value) pairs. See "Network.HTTP.Types.Header" for the possible values.+            , isSecure :: Bool -- ^ Was this request made over SSL/TLS?+            , remoteHost :: SockAddr -- ^ The address information of the client.+            , pathInfo :: [Text] -- ^ The URL, stripped of hostname and port, split on forward-slashes+            , queryString :: Query -- ^ Parsed query string information.+            , requestBody :: m ByteString -- ^ A monadic action that extracts a (possibly-empty) chunk of the request body.+            , requestBodyLength :: Wai.RequestBodyLength -- ^ Either @ChunkedBody@ or a @KnownLength 'Word64'@.+            , requestHeaderHost :: Maybe ByteString -- ^ Contains the Host header.+            , requestHeaderRange :: Maybe ByteString -- ^ Contains the Range header.+            }++defaultRequest :: Monad m => Request m+defaultRequest = Request+    { requestMethod = HTTP.methodGet+    , httpVersion = HTTP.http10+    , rawPathInfo = BS.empty+    , rawQueryString = BS.empty+    , requestHeaders = []+    , isSecure = False+    , remoteHost = SockAddrInet 0 0+    , pathInfo = []+    , queryString = []+    , requestBody = return BS.empty+    , requestBodyLength = Wai.KnownLength 0+    , requestHeaderHost = Nothing+    , requestHeaderRange = Nothing+    }++-- | Reads the entirety of the request body in a single string.+-- This turns the chunks obtained from repeated invocations of 'requestBody' into a lazy 'ByteString'.+entireRequestBody :: Monad m => Request m -> m LB.ByteString+entireRequestBody req = requestBody req >>= strictRequestBody' LB.empty+    where strictRequestBody' acc prev+            | BS.null prev = return acc+            | otherwise = requestBody req >>= strictRequestBody' (acc <> LB.fromStrict prev)++data RequestReader m = RequestReader { _now :: UTCTime+                                     , _request :: Request m+                                     }++data ETag = Strong ByteString+          | Weak ByteString+          deriving (Eq)++instance Show ETag where show = unpack . etagToByteString++etagToByteString :: ETag -> ByteString+etagToByteString (Strong bs) = "\"" <> bs <> "\""+etagToByteString (Weak bs) = "W/\"" <> bs <> "\""++type StreamingBody m = (Builder -> m ()) -> m () -> m ()++-- | Basically Wai's unexported 'Response' type, but generalized to any monad,+-- 'm'.+data ResponseBody m+    = ResponseFile FilePath (Maybe Wai.FilePart)+    | ResponseBuilder Builder+    | ResponseStream (StreamingBody m)+    | Empty+    -- ResponseRaw ... (not implemented yet, but useful for websocket upgrades)++-- | Helper function for building a `ResponseBuilder` out of HTML-escaped text.+escapedResponse :: Text -> ResponseBody m+escapedResponse = ResponseBuilder . fromHtmlEscapedText++data Response m = Response { _responseStatus     :: Status+                           , _responseHeaders    :: ResponseHeaders+                           , _responseBody       :: ResponseBody m+                           }++data ResponseState s m = ResponseState { stateUser      :: s+                                       , stateHeaders   :: ResponseHeaders+                                       , stateBody      :: ResponseBody m+                                       , _params :: HashMap Text Text+                                       }++type Trace = [Text]++newtype Webmachine s m a =+    Webmachine { getWebmachine :: EitherT (Response m) (RWST (RequestReader m) Trace (ResponseState s m) m) a }+        deriving (Functor, Applicative, Monad, MonadIO, MonadBase b,+                  MonadReader (RequestReader m),+                  MonadWriter Trace,+                  MonadState (ResponseState s m))++instance MonadTrans (Webmachine s) where+    lift = Webmachine . EitherT . (>>= return . Right) . lift++newtype StMWebmachine s m a = StMWebmachine {+      unStMWebmachine :: StM (EitherT (Response m) (RWST (RequestReader m) Trace (ResponseState s m) m)) a+    }++instance MonadBaseControl b m => MonadBaseControl b (Webmachine s m) where+  type StM (Webmachine s m) a = StMWebmachine s m a+  liftBaseWith f = Webmachine+                     $ liftBaseWith+                     $ \g' -> f+                     $ \m -> liftM StMWebmachine+                     $ g' $ getWebmachine m+  restoreM = Webmachine . restoreM . unStMWebmachine++-- | A convenience synonym that writes the @Monad@ type constraint for you.+type Handler s m a = Monad m => Webmachine s m a++-- Functions inside the Webmachine Monad -------------------------------------+------------------------------------------------------------------------------++-- | Returns the 'Request' that this 'Handler' is currently processing.+request :: Handler s m (Request m)+request = _request <$> ask++-- | Returns the bound routing parameters extracted from the routing system (see "Airship.Route").+params :: Handler s m (HashMap Text Text)+params = _params <$> get++-- | Returns the time at which this request began processing.+requestTime :: Handler s m UTCTime+requestTime = _now <$> ask++-- | Returns the user state (of type @s@) in the provided @'Handler' s m@.+getState :: Handler s m s+getState = stateUser <$> get++-- | Sets the user state.+putState :: s -> Handler s m ()+putState s = modify updateState+    where updateState rs = rs {stateUser = s}++-- | Applies the provided function to the user state.+modifyState :: (s -> s) -> Handler s m ()+modifyState f = modify modifyState'+    where modifyState' rs@ResponseState{stateUser=uState} =+                                        rs {stateUser = f uState}++-- | Returns the 'ResponseHeaders' stored in the current 'Handler'.+getResponseHeaders :: Handler s m ResponseHeaders+getResponseHeaders = stateHeaders <$> get++-- | Returns the current 'ResponseBody' that this 'Handler' is storing.+getResponseBody :: Handler s m (ResponseBody m)+getResponseBody = stateBody <$> get++-- | Given a new 'ResponseBody', replaces the stored body with the new one.+putResponseBody :: ResponseBody m -> Handler s m ()+putResponseBody b = modify updateState+    where updateState rs = rs {stateBody = b}++-- | Stores the provided 'ByteString' as the responseBody. This is a shortcut for+-- creating a response body with a 'ResponseBuilder' and a bytestring 'Builder'.+putResponseBS :: ByteString -> Handler s m ()+putResponseBS bs = putResponseBody $ ResponseBuilder $ fromByteString bs++-- | Immediately halts processing with the provided 'Status' code.+-- The contents of the 'Handler''s response body will be streamed back to the client.+-- This is a shortcut for constructing a 'Response' with 'getResponseHeaders' and 'getResponseBody'+-- and passing that response to 'finishWith'.+halt :: Status -> Handler m s a+halt status = finishWith =<< Response <$> pure status <*> getResponseHeaders <*> getResponseBody++-- | Immediately halts processing and writes the provided 'Response' back to the client.+finishWith :: Response m -> Handler s m a+finishWith = Webmachine . left++-- | 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)]++both :: Either a a -> a+both = either id id++eitherResponse :: Monad m => UTCTime -> HashMap Text Text -> Request m -> s -> Handler s m (Response m) -> m (Response m, Trace)+eitherResponse reqDate reqParams req s resource = do+    (e, trace) <- runWebmachine reqDate reqParams req s resource+    return (both e, trace)++runWebmachine :: Monad m => UTCTime -> HashMap Text Text -> Request m -> s -> Handler s m a -> m (Either (Response m) a, Trace)+runWebmachine reqDate reqParams req s w = do+    let startingState = ResponseState s [] Empty reqParams+        requestReader = RequestReader reqDate req+    (e, _, t) <- runRWST (runEitherT (getWebmachine w)) requestReader startingState+    return (e, t)
+ test/unit/test.hs view
@@ -0,0 +1,50 @@+{-# LANGUAGE OverloadedStrings #-}++module Main where++import Airship+import Control.Monad.Trans.State.Strict (State, evalState, get, put)+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as LB+import Data.ByteString (ByteString)++import Test.Tasty+import Test.Tasty.HUnit++main :: IO ()+main = defaultMain tests++tests :: TestTree+tests = testGroup "Tests" [examples]++examples :: TestTree+examples = testGroup "Examples" [exampleTests]++exampleTests :: TestTree+exampleTests = testGroup "ExampleTests"+  [ bodyTest ]++type RequestState = State [ByteString]++bodyChunks :: [ByteString]+bodyChunks = ["one", "two", "three", "four", "five"]++nextBody :: RequestState ByteString+nextBody = do+    s <- get+    if null s+        then return BS.empty+        else do+            let (h:tl) = s+            put tl+            return h++bodyTest :: TestTree+bodyTest = testCase "entireRequestBody returns the body in the correct order" bodyTest'+    where bodyTest' = evalState state bodyChunks @?= "onetwothreefourfive"+          state :: RequestState LB.ByteString+          state = entireRequestBody req+          req = defRequest { requestBody = nextBody }+          -- for some reason this type signature seems to be necessary+          defRequest :: Request RequestState+          defRequest = defaultRequest