packages feed

webcrank (empty) → 0.1

raw patch · 17 files changed

+1770/−0 lines, 17 filesdep +QuickCheckdep +attoparsecdep +basesetup-changed

Dependencies added: QuickCheck, attoparsec, base, blaze-builder, bytestring, case-insensitive, either, exceptions, http-date, http-media, http-types, lens, mtl, network-uri, semigroups, tasty, tasty-hunit, tasty-quickcheck, text, transformers, unordered-containers, utf8-string, webcrank

Files

+ LICENSE view
@@ -0,0 +1,25 @@+Copyright (c) 2012, Webcrank, Mark Hibberd and others.++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:+1. Redistributions of source code must retain the above copyright+   notice, this list of conditions and the following disclaimer.+2. 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.+3. The name of the author may not be used to endorse or promote products+   derived from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``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 AUTHOR 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.
+ Setup.hs view
@@ -0,0 +1,5 @@+#!/usr/bin/env runhaskell++import Distribution.Simple++main = defaultMain
+ src/Webcrank.hs view
@@ -0,0 +1,179 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}++module Webcrank+  ( -- * Resources+    Resource(..)+  , resource+  , resourceWithBody+  , resourceWithHtml+  , Encoding+  , Authorized(..)+  , ETag(..)+  , PostAction(..)+  , postCreate+  , postCreateRedir+  , postProcess+  , postProcessRedir+  , HaltT+  , halt+  , werror+    -- * Charsets+  , Charset+  , CharsetsProvided(..)+  , provideCharsets+    -- * Headers+  , HeadersMap+  , addResponseHeader+  , putResponseHeader+    -- * Body+  , Body+  , textBody+  , lazyTextBody+  , strBody+  , writeLBS+  , writeStr+    -- * Extra convience (re)exports+  , module Network.HTTP.Date+  , module Network.HTTP.Media+  , module Network.HTTP.Types+  , hAcceptCharset+  , hAcceptEncoding+  , hAllow+  , hETag+  , hExpires+  , hIfMatch+  , hIfNoneMatch+  , hIfUnmodifiedSince+  , hTransferEncoding+  , hVary+  , hWWWAuthenticate+  ) where++import Control.Lens+import Control.Monad+import Control.Monad.State+import Data.ByteString (ByteString)+import qualified Data.ByteString.Lazy as LB+import Data.List.NonEmpty+import qualified Data.HashMap.Strict as HashMap+import Data.Monoid+import Data.Text (Text)+import qualified Data.Text.Encoding as T+import qualified Data.Text.Lazy as LT+import qualified Data.Text.Lazy.Encoding as LT+import Network.HTTP.Date+import Network.HTTP.Media+import Network.HTTP.Types++import Webcrank.Internal.Halt+import Webcrank.Internal.Headers+import Webcrank.Internal.ReqData+import Webcrank.Internal.Types++-- | Builds a @Resource m@ value where all the resource functions will+-- return default values as described in the @'Resource'@ function+-- documentation.+resource :: Monad m => Resource m+resource = Resource+  { serviceAvailable = return True+  , uriTooLong = return False+  , allowedMethods = return [methodGet, methodHead]+  , malformedRequest = return False+  , isAuthorized = return Authorized+  , forbidden = return False+  , validContentHeaders = return True+  , knownContentType = return True+  , validEntityLength = return True+  , options = return []+  , contentTypesProvided = return []+  , charsetsProvided = return NoCharset+  , encodingsProvided = return []+  , resourceExists = return True+  , generateETag = mzero+  , lastModified = mzero+  , expires = mzero+  , movedPermanently = mzero+  , movedTemporarily = mzero+  , previouslyExisted = return False+  , allowMissingPost = return False+  , deleteResource = return False+  , deleteCompleted = return True+  , postAction = postProcess $ return ()+  , contentTypesAccepted = return []+  , variances = return []+  , multipleChoices = return False+  , isConflict = return False+  , finishRequest = return ()+  }++-- | Creates a resource that provides a single content type.+resourceWithBody :: Monad m => MediaType -> m Body -> Resource m+resourceWithBody t b = resource { contentTypesProvided = return [(t, lift b)] }+{-# INLINE resourceWithBody #-}++-- | Creates a resource that provides a @text/html@ content type.+resourceWithHtml :: Monad m => m Body -> Resource m+resourceWithHtml b = resourceWithBody "text/html" b+{-# INLINE resourceWithHtml #-}++-- | Shortcut for @return . CharsetsProvided@+provideCharsets+  :: Monad m+  => NonEmpty (Charset, Body -> Body)+  -> m CharsetsProvided+provideCharsets = return . CharsetsProvided+{-# INLINE provideCharsets #-}++-- | Add a header to the response.+addResponseHeader+  :: (MonadState s m, HasReqData s)+  => HeaderName+  -> ByteString+  -> m ()+addResponseHeader h v = reqDataRespHeaders %= HashMap.insertWith (<>) h [v]+{-# INLINE addResponseHeader #-}++-- | Create a @PostAction@ which performs resource creation without redirecting.+postCreate :: Monad m => [Text] -> m (PostAction m)+postCreate = return . PostCreate+{-# INLINE postCreate #-}++-- | Create a @PostAction@ which performs resource creation and redirects.+postCreateRedir :: Monad m => [Text] -> m (PostAction m)+postCreateRedir = return . PostCreateRedir+{-# INLINE postCreateRedir #-}++-- | Create a @PostAction@ which runs some process and does not redirect.+postProcess :: Monad m => HaltT m () -> m (PostAction m)+postProcess = return . PostProcess+{-# INLINE postProcess #-}++-- | Create a @PostAction@ which runs some process and does redirects.+postProcessRedir :: Monad m => HaltT m ByteString -> m (PostAction m)+postProcessRedir = return . PostProcessRedir+{-# INLINE postProcessRedir #-}++-- | Create a response @Body@ from strict @Text@.+textBody :: Text -> Body+textBody = LB.fromStrict . T.encodeUtf8+{-# INLINE textBody #-}++-- | Create a response @Body@ from lazy @Text@.+lazyTextBody :: LT.Text -> Body+lazyTextBody = LT.encodeUtf8+{-# INLINE lazyTextBody #-}++-- | Create a response @Body@ from a @String@.+strBody :: String -> Body+strBody = lazyTextBody . LT.pack+{-# INLINE strBody #-}++-- | Set the response body from a @String@+writeStr+  :: (MonadState s m, HasReqData s)+  => String+  -> m ()+writeStr = assign reqDataRespBody . Just . strBody+{-# INLINE writeStr #-}+
+ src/Webcrank/Internal.hs view
@@ -0,0 +1,9 @@+module Webcrank.Internal+  ( module X+  ) where++import Webcrank.Internal.Parsers as X+import Webcrank.Internal.ReqData as X+import Webcrank.Internal.ResourceData as X+import Webcrank.Internal.Types as X+
+ src/Webcrank/Internal/DecisionCore.hs view
@@ -0,0 +1,632 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TupleSections #-}++module Webcrank.Internal.DecisionCore where++import qualified Blaze.ByteString.Builder as BB+import Control.Applicative+import Control.Lens+import Control.Monad.Reader+import Control.Monad.RWS+import Control.Monad.Trans.Either+import Control.Monad.Trans.Maybe+import Data.ByteString (ByteString)+import qualified Data.ByteString as B hiding (drop, take)+import qualified Data.ByteString.Lazy as LB+import qualified Data.ByteString.UTF8 as B+import qualified Data.CaseInsensitive as CI+import Data.Foldable (find, traverse_)+import qualified Data.List as List+import qualified Data.List.NonEmpty as NE+import Data.Maybe+import Data.Text (Text)+import Network.HTTP.Date+import Network.HTTP.Media+import Network.HTTP.Types++import Webcrank.Internal.ETag+import Webcrank.Internal.Headers+import Webcrank.Internal.Types+import Webcrank.Internal.ReqData+import Webcrank.Internal.ResourceData++data FlowChart m a where+  Decision :: String -> m (FlowChart m a) -> FlowChart m a+  Done :: m a -> FlowChart m a++decision+  :: String               -- label+  -> m (FlowChart m a)    -- next step+  -> FlowChart m a+decision = Decision++decision'+  :: Functor m+  => String        -- label+  -> m Bool        -- condition+  -> FlowChart m a -- false path+  -> FlowChart m a -- true path+  -> FlowChart m a+decision' lbl cond ff tf = decision lbl (bool ff tf <$> cond)++done :: m a -> FlowChart m a+done = Done++done' :: (Applicative m, Monad m) => a -> FlowChart m a+done' = Done . return++runFlowChart :: Monad m => FlowChart m a -> m a+runFlowChart = \case+  Decision _ m -> m >>= runFlowChart+  Done m -> m++respond :: Monad m => Status -> FlowChart (HaltT m) Status+respond s =+  if statusCode s >= 400 && statusCode s < 600+    then done $ errorResponse' s+    else done' s++errorResponse :: Monad m => Status -> LB.ByteString -> HaltT m a+errorResponse s = HaltT . left . Error s++errorResponse' :: Monad m => Status -> HaltT m a+errorResponse' s = errorResponse s (LB.fromStrict $ statusMessage s)++-- Service Available+b13+  :: (Applicative m, MonadReader r m, HasResourceData r m, MonadState s m, HasReqData s)+  => FlowChart (HaltT m) Status+b13 = decision' "b13" (callr serviceAvailable) (respond serviceUnavailable503) b12++-- Known method?+b12+  :: (Applicative m, MonadReader r m, HasResourceData r m, MonadState s m, HasReqData s)+  => FlowChart (HaltT m) Status+b12 = decision' "b12" knownMethod (respond notImplemented501) b11 where+  knownMethod = (`elem` knownMethods) <$> getRequestMethod+  -- TODO make it part of the config or part of the resource?+  knownMethods = [methodGet, methodHead, methodPost, methodPut, methodDelete, methodTrace, methodConnect, methodOptions]++-- URI too long?+b11+  :: (Applicative m, MonadReader r m, HasResourceData r m, MonadState s m, HasReqData s)+  => FlowChart (HaltT m) Status+b11 = decision' "b11" (callr uriTooLong) b10 (respond requestURITooLong414)++-- Method allowed?+b10+  :: (Applicative m, MonadReader r m, HasResourceData r m, MonadState s m, HasReqData s)+  => FlowChart (HaltT m) Status+b10 = decision "b10" $ do+  ms <- callr' allowedMethods+  m <- getRequestMethod+  if m `elem` ms+     then return b9+     else do+       putResponseHeader hAllow (B.intercalate ", " ms)+       return $ respond methodNotAllowed405++-- Malformed?+b9+  :: (Applicative m, MonadReader r m, HasResourceData r m, MonadState s m, HasReqData s)+  => FlowChart (HaltT m) Status+b9 = decision' "b9" (callr malformedRequest) b8 (respond badRequest400)++-- Authorized?+b8+  :: (Applicative m, MonadReader r m, HasResourceData r m, MonadState s m, HasReqData s)+  => FlowChart (HaltT m) Status+b8 = decision "b8" $ callr isAuthorized >>= \case+  Authorized -> return b7+  Unauthorized h -> do+    putResponseHeader hWWWAuthenticate h+    return $ respond unauthorized401++-- Forbidden?+b7+  :: (Applicative m, MonadReader r m, HasResourceData r m, MonadState s m, HasReqData s)+  => FlowChart (HaltT m) Status+b7 = decision' "b7" (callr forbidden) b6 (respond forbidden403)++-- Okay Content-* Headers?+b6+  :: (Applicative m, MonadReader r m, HasResourceData r m, MonadState s m, HasReqData s)+  => FlowChart (HaltT m) Status+b6 = decision' "b6" (callr validContentHeaders) (respond notImplemented501) b5++-- Known Content-Type?+b5+  :: (Applicative m, MonadReader r m, HasResourceData r m, MonadState s m, HasReqData s)+  => FlowChart (HaltT m) Status+b5 = decision' "b5" (callr knownContentType) (respond unsupportedMediaType415) b4++-- Req Entity Too Large?+b4+  :: (Applicative m, MonadReader r m, HasResourceData r m, MonadState s m, HasReqData s)+  => FlowChart (HaltT m) Status+b4 = decision' "b4" (callr validEntityLength) (respond requestEntityTooLarge413) b3++-- OPTIONS?+b3+  :: (Applicative m, MonadReader r m, HasResourceData r m, MonadState s m, HasReqData s)+  => FlowChart (HaltT m) Status+b3 = decision "b3" $ getRequestMethod >>= \m ->+  if m == methodOptions+    then respond ok200 <$ (callr' options >>= putResponseHeaders)+    else return c3++-- Accept exists?+c3+  :: (Applicative m, MonadReader r m, HasResourceData r m, MonadState s m, HasReqData s)+  => FlowChart (HaltT m) Status+c3 = decision "c3" $ getRequestHeader hAccept >>= maybe d4' (return . c4) where+  d4' = do+    ts <- callr' contentTypesProvided+    traverse_ (assign reqDataRespMediaType . fst) (listToMaybe ts)+    return d4++-- Acceptable media type available?+c4+  :: (Applicative m, MonadReader r m, HasResourceData r m, MonadState s m, HasReqData s)+  => ByteString+  -> FlowChart (HaltT m) Status+c4 acc = decision "c4" $ maybe (return noAcc) d4' =<< match where+  d4' = (d4 <$) . assign reqDataRespMediaType+  match = flip matchAccept acc . fmap fst <$> callr' contentTypesProvided+  noAcc = done $ errorResponse notAcceptable406 "No acceptable media type available"++-- Accept-Language exists?+d4+  :: (Applicative m, MonadReader r m, HasResourceData r m, MonadState s m, HasReqData s)+  => FlowChart (HaltT m) Status+d4 = decision "d4" $ maybe e5 d5 <$> getRequestHeader hAcceptLanguage++-- Acceptable Language available?+-- TODO implement proper conneg+d5+  :: (Applicative m, MonadReader r m, HasResourceData r m, MonadState s m, HasReqData s)+  => ByteString+  -> FlowChart (HaltT m) Status+d5 _ = decision "d5" $ return e5++-- Accept-Charset exists?+e5+  :: (Applicative m, MonadReader r m, HasResourceData r m, MonadState s m, HasReqData s)+  => FlowChart (HaltT m) Status+e5 = decision "e5" $ getRequestHeader hAcceptCharset >>=+  maybe (f6 <$ setCharsetFrom "*") (return . e6)++-- Acceptable Charset available?+e6+  :: (Applicative m, MonadReader r m, HasResourceData r m, MonadState s m, HasReqData s)+  => ByteString+  -> FlowChart (HaltT m) Status+e6 acc = decision "e6" $ f6 <$ setCharsetFrom acc++setCharsetFrom+  :: (Applicative m, MonadReader r m, HasResourceData r m, MonadState s m, HasReqData s)+  => ByteString+  -> HaltT m ()+setCharsetFrom acc = callr' charsetsProvided >>= match where+  match = \case+    NoCharset -> return ()+    CharsetsProvided cs -> match' (fst <$> NE.toList cs)+  match' = maybe noAcc matched . flip matchAccept acc+  matched = assign reqDataRespCharset . Just+  noAcc = errorResponse notAcceptable406 "No acceptable charset available"++-- Accept-Encoding exists?+-- also set Content-Type header now that charset is chosen+f6+  :: (Applicative m, MonadReader r m, HasResourceData r m, MonadState s m, HasReqData s)+  => FlowChart (HaltT m) Status+f6 = decision "f6" $ do+  putResponseHeader hContentType =<< do+    mt <- use reqDataRespMediaType+    cs <- use reqDataRespCharset+    return $ renderHeader $ maybe mt ((mt /:) . ("charset",) . CI.original) cs++  acc <- getRequestHeader hAcceptEncoding+  maybe (g7 <$ chooseEncoding "identity;q=1.0,*,q=0.5") (return . f7) acc++-- Acceptable encoding available?+--+-- Note: This is a departure from webmachine and the activity diagram.+-- Webcrank will NEVER give a "406 Not Acceptable" response if an encoding+-- cannot be found.+--+--   If an Accept-Encoding header field is present in a request and none of+--   the available representations for the response have a content-coding+--   that is listed as acceptable, the origin server SHOULD send a response+--   without any content-coding.+--+-- http://tools.ietf.org/html/draft-ietf-httpbis-p2-semantics-24#section-5.3.4+f7+  :: (Applicative m, MonadReader r m, HasResourceData r m, MonadState s m, HasReqData s)+  => ByteString+  -> FlowChart (HaltT m) Status+f7 acc = decision "f7" $ g7 <$ chooseEncoding acc++chooseEncoding+  :: (Applicative m, MonadReader r m, HasResourceData r m, MonadState s m, HasReqData s)+  => ByteString+  -> HaltT m ()+chooseEncoding acc = callr' encodingsProvided >>= choose where+  choose = traverse_ putEnc . match . (fst <$>)+  match es = matchAccept es acc >>= \case+    "identity" -> Nothing+    e -> Just e+  putEnc e = do+    putResponseHeader hContentEncoding (CI.original e)+    reqDataRespEncoding .= Just e++-- Resource exists?+-- also sets variances now that all conneg is done+g7+  :: (Applicative m, MonadReader r m, HasResourceData r m, MonadState s m, HasReqData s)+  => FlowChart (HaltT m) Status+g7 = decision "g7" $ do+   getVariances >>= \case+     [] -> return ()+     vs -> putResponseHeader hVary $ renderHeader vs++   bool h7 g8 <$> callr resourceExists++getVariances+  :: (Applicative m, MonadReader r m, HasResourceData r m, MonadState s m, HasReqData s)+  => HaltT m [HeaderName]+getVariances = do+  acc <- bool [] [hAccept] . (> 1) . List.length <$> callr' contentTypesProvided+  accEnc <- bool [] [hAcceptEncoding] . (> 1) . List.length <$> callr' encodingsProvided+  accCh <- flip fmap (callr' charsetsProvided) $ \case+    NoCharset -> []+    CharsetsProvided cs -> [hAcceptCharset | NE.length cs > 1]+  vs <- callr' variances+  return $ mconcat [acc, accEnc, accCh, vs]++-- If-Match exists?+g8+  :: (Applicative m, MonadReader r m, HasResourceData r m, MonadState s m, HasReqData s)+  => FlowChart (HaltT m) Status+g8 = decision "g8" $ maybe h10 g9 <$> getRequestHeader hIfMatch++-- If-Match: * exists+g9+  :: (Applicative m, MonadReader r m, HasResourceData r m, MonadState s m, HasReqData s)+  => ByteString+  -> FlowChart (HaltT m) Status+g9 h = decision "g9" $ return $ bool (g11 h) h10 (h == "*")++-- ETag in If-Match+g11+  :: (Applicative m, MonadReader r m, HasResourceData r m, MonadState s m, HasReqData s)+  => ByteString+  -> FlowChart (HaltT m) Status+g11 h = decision "g11" $ check <$> callr' (runMaybeT . generateETag) where+  check = maybe (respond preconditionFailed412) (const h10) . mfilter test+  test e = any (strongComparison e) (parseETags h)++-- If-Match exists (no existing resource variant)?+h7+  :: (Applicative m, MonadReader r m, HasResourceData r m, MonadState s m, HasReqData s)+  => FlowChart (HaltT m) Status+h7 = decision "h7" $ maybe i7 (const $ respond preconditionFailed412) <$> getRequestHeader hIfMatch++-- If-Unmodified-Since exists?+h10+  :: (Applicative m, MonadReader r m, HasResourceData r m, MonadState s m, HasReqData s)+  => FlowChart (HaltT m) Status+h10 = decision "h10" $ maybe i12 h11 <$> getRequestHeader hIfUnmodifiedSince++-- If-Unmodified-Since is valid date?+h11+  :: (Applicative m, MonadReader r m, HasResourceData r m, MonadState s m, HasReqData s)+  => ByteString+  -> FlowChart (HaltT m) Status+h11 = decision "h11" . return . maybe i12 h12 . parseHTTPDate++-- Last-Modified > If-Unmodified-Since?+h12+  :: (Applicative m, MonadReader r m, HasResourceData r m, MonadState s m, HasReqData s)+  => HTTPDate+  -> FlowChart (HaltT m) Status+h12 ius = decision "h12" $ check <$> callr' (runMaybeT . lastModified) where+  check = maybe (respond preconditionFailed412) (const i12) . mfilter (<= ius)++-- Moved permanently? (apply PUT to different URI)+i4+  :: (Applicative m, MonadReader r m, HasResourceData r m, MonadState s m, HasReqData s)+  => FlowChart (HaltT m) Status+i4 = decision "i4" $ movedPermanentlyOr p3++movedPermanentlyOr+  :: (Applicative m, MonadReader r m, HasResourceData r m, MonadState s m, HasReqData s)+  => FlowChart (HaltT m) Status+  -> HaltT m (FlowChart (HaltT m) Status)+movedPermanentlyOr n = check =<< callr (runMaybeT . movedPermanently) where+  check = maybe (return n) moved+  moved uri = respond movedPermanently301 <$ putResponseLocation uri++-- PUT?+i7+  :: (Applicative m, MonadReader r m, HasResourceData r m, MonadState s m, HasReqData s)+  => FlowChart (HaltT m) Status+i7 = decision "i7" $ bool k7 i4 . (== methodPut) <$> getRequestMethod++-- If-None-Match exists?+i12+  :: (Applicative m, MonadReader r m, HasResourceData r m, MonadState s m, HasReqData s)+  => FlowChart (HaltT m) Status+i12 = decision "i12" $ maybe l13 i13 <$> getRequestHeader hIfNoneMatch++-- If-None-Match: * exists?+i13+  :: (Applicative m, MonadReader r m, HasResourceData r m, MonadState s m, HasReqData s)+  => ByteString+  -> FlowChart (HaltT m) Status+i13 h = decision "i13" $ return $ bool (k13 h) j18 (h == "*")++-- GET or HEAD (resource exists)?+j18+  :: (Applicative m, MonadReader r m, HasResourceData r m, MonadState s m, HasReqData s)+  => FlowChart (HaltT m) Status+j18 = decision "j18" $ respond . s <$> getRequestMethod where+  s = bool preconditionFailed412 notModified304 . (`elem` [methodGet, methodHead])++-- Moved permanently? (non-PUT edition)+k5+  :: (Applicative m, MonadReader r m, HasResourceData r m, MonadState s m, HasReqData s)+  => FlowChart (HaltT m) Status+k5 = decision "k5" $ movedPermanentlyOr l5++-- Previously existed?+k7+  :: (Applicative m, MonadReader r m, HasResourceData r m, MonadState s m, HasReqData s)+  => FlowChart (HaltT m) Status+k7 = decision "k7" $ bool l7 k5 <$> callr previouslyExisted++-- Etag in if-none-match?+k13+  :: (Applicative m, MonadReader r m, HasResourceData r m, MonadState s m, HasReqData s)+  => ByteString+  -> FlowChart (HaltT m) Status+k13 h = decision "k13" $ check <$> callr' (runMaybeT . generateETag) where+  check = maybe l13 (const j18) . mfilter (`elem` inm)+  inm = parseETags h++-- Moved temporarily?+l5+  :: (Applicative m, MonadReader r m, HasResourceData r m, MonadState s m, HasReqData s)+  => FlowChart (HaltT m) Status+l5 = decision "l5" $ callr (runMaybeT . movedTemporarily) >>= check where+  check = maybe (return m5) redirect+  redirect uri = respond temporaryRedirect307 <$ putResponseLocation uri++-- POST? (resource did not previously exist variant)+l7+  :: (Applicative m, MonadReader r m, HasResourceData r m, MonadState s m, HasReqData s)+  => FlowChart (HaltT m) Status+l7 = decision' "l7" ((== methodPost) <$> getRequestMethod) (respond notFound404) m7++-- If-Modified-Since exists?+l13+  :: (Applicative m, MonadReader r m, HasResourceData r m, MonadState s m, HasReqData s)+  => FlowChart (HaltT m) Status+l13 = decision "l13" $ maybe m16 l14 <$> getRequestHeader hIfModifiedSince++-- If-Modified-Since is a valid date?+l14+  :: (Applicative m, MonadReader r m, HasResourceData r m, MonadState s m, HasReqData s)+  => ByteString+  -> FlowChart (HaltT m) Status+l14 = decision "l14" . return . maybe m16 l15 . parseHTTPDate++-- If-Modified-Since > Now?+l15+  :: (Applicative m, MonadReader r m, HasResourceData r m, MonadState s m, HasReqData s)+  => HTTPDate+  -> FlowChart (HaltT m) Status+l15 ims = decision' "l15" ((ims >) <$> getRequestTime) (l17 ims) m16++-- Last-Modified > If-Modified-Since?+l17+  :: (Applicative m, MonadReader r m, HasResourceData r m, MonadState s m, HasReqData s)+  => HTTPDate+  -> FlowChart (HaltT m) Status+l17 ims = decision "l17" $ check <$> callr' (runMaybeT . lastModified) where+  check = maybe m16 (const $ respond notModified304) . mfilter (<= ims)++-- POST? (resource previously existed variant)+m5+  :: (Applicative m, MonadReader r m, HasResourceData r m, MonadState s m, HasReqData s)+  => FlowChart (HaltT m) Status+m5 = decision' "m5" ((== methodPost) <$> getRequestMethod) (respond gone410) n5++-- Server allows POST to missing resource?+m7+  :: (Applicative m, MonadReader r m, HasResourceData r m, MonadState s m, HasReqData s)+  => FlowChart (HaltT m) Status+m7 = decision' "m7" (callr allowMissingPost) (respond notFound404) n11++-- DELETE?+m16+  :: (Applicative m, MonadReader r m, HasResourceData r m, MonadState s m, HasReqData s)+  => FlowChart (HaltT m) Status+m16 = decision' "m16" ((== methodDelete) <$> getRequestMethod) n16 m20++-- DELETE and check for completion?+m20+  :: (Applicative m, MonadReader r m, HasResourceData r m, MonadState s m, HasReqData s)+  => FlowChart (HaltT m) Status+m20 = decision "m20" $ callr deleteResource >>= \r ->+  if r+    then bool (respond accepted202) n11 <$> callr deleteCompleted+    else return $ respond internalServerError500++-- Server allows POST to missing resource? (resource did not exist previously)+n5+  :: (Applicative m, MonadReader r m, HasResourceData r m, MonadState s m, HasReqData s)+  => FlowChart (HaltT m) Status+n5 = decision' "n5" (callr allowMissingPost) (respond gone410) n11++-- Redirect?+n11+  :: (Applicative m, MonadReader r m, HasResourceData r m, MonadState s m, HasReqData s)+  => FlowChart (HaltT m) Status+n11 = decision "n11" $ callr' postAction >>= run where+  run = \case+    PostCreate p ->+      p11 <$ create p+    PostCreateRedir p ->+      respond seeOther303 <$ create p+    PostProcess process ->+      p11 <$ (process >> encodeBodyIfSet)+    PostProcessRedir process ->+      respond seeOther303 <$ (process >>= putResponseLocation >> encodeBodyIfSet)++  create newPath = do+    reqURI <- getRequestURI+    reqDataDispPath .= newPath+    putResponseLocation $ appendPath reqURI newPath+    accept++appendPath :: ByteString -> [Text] -> ByteString+appendPath uri p = h <> p'' where+  (h, p') = splitURI uri+  p'' = p' <> dropSlash (BB.toByteString (encodePathSegments p))+  dropSlash = B.drop (if B.last p' == 47 then 1 else 0)++splitURI :: ByteString -> (ByteString, ByteString)+splitURI = ensureNonEmpty . extract where+  extract path+    | "http://" `B.isPrefixOf` path = split 7 path+    | "https://" `B.isPrefixOf` path = split 8 path+    | otherwise = ("", path)+  ensureNonEmpty (b, "") = (b, "/")+  ensureNonEmpty p  = p+  split i path = case breakOnSlash $ B.drop i path of+    (a, p) -> (B.take i path <> a, p)+  breakOnSlash = B.breakByte 47++-- POST? (resource exists)+n16+  :: (Applicative m, MonadReader r m, HasResourceData r m, MonadState s m, HasReqData s)+  => FlowChart (HaltT m) Status+n16 = decision' "n16" ((== methodPost) <$> getRequestMethod) o16 n11++-- Conflict? (resource exists)+o14+  :: (Applicative m, MonadReader r m, HasResourceData r m, MonadState s m, HasReqData s)+  => FlowChart (HaltT m) Status+o14 = decision "o14" isConflict'++isConflict'+  :: (Applicative m, MonadReader r m, HasResourceData r m, MonadState s m, HasReqData s)+  => HaltT m (FlowChart (HaltT m) Status)+isConflict' = callr' isConflict >>= \conflict ->+  if conflict+    then return $ respond conflict409+    else p11 <$ accept++-- PUT? (resource exists)+o16+  :: (Applicative m, MonadReader r m, HasResourceData r m, MonadState s m, HasReqData s)+  => FlowChart (HaltT m) Status+o16 = decision' "o16" ((== methodPut) <$> getRequestMethod) o18 o14++-- Multiple representations?+-- also generate body for GET and HEAD+o18+  :: (Applicative m, MonadReader r m, HasResourceData r m, MonadState s m, HasReqData s)+  => FlowChart (HaltT m) Status+o18 = decision "o18" $ genBody >> next where+  genBody = do+    m <- getRequestMethod+    putHeaders m+    putBody m++  putHeaders m = when (m == methodGet || m == methodHead) $ do+    let header h rm = traverse_ (putResponseHeader h . renderHeader) =<< callr' (runMaybeT . rm)+    header hETag generateETag+    header hLastModified lastModified+    header hExpires expires++  putBody m = when (m == methodGet) $ use reqDataRespMediaType >>= \mt ->+    callr' contentTypesProvided >>= \cts ->+      case find ((mt ==) . fst) cts of+        Nothing -> return ()+        Just (_, f) -> f >>= encodeBody >>= assign reqDataRespBody . Just++  next = bool (respond ok200) (respond multipleChoices300) <$> callr multipleChoices++-- Response includes an entity?+o20+  :: (Applicative m, MonadReader r m, HasResourceData r m, MonadState s m, HasReqData s)+  => FlowChart (HaltT m) Status+o20 = decision "o20" $+  maybe (respond noContent204) (const o18) <$> use reqDataRespBody++-- Conflict? (resource doesn't exist)+p3+  :: (Applicative m, MonadReader r m, HasResourceData r m, MonadState s m, HasReqData s)+  => FlowChart (HaltT m) Status+p3 = decision "p3" isConflict'++-- New resource? (new if there is a location header)+p11+  :: (Applicative m, MonadReader r m, HasResourceData r m, MonadState s m, HasReqData s)+  => FlowChart (HaltT m) Status+p11 = decision "p11" $+  maybe o20 (const $ respond created201) <$> getResponseLocation++accept+  :: (Applicative m, MonadReader r m, HasResourceData r m, MonadState s m, HasReqData s)+  => HaltT m ()+accept = getRequestContentType >>= accept' >> encodeBodyIfSet where+  getRequestContentType =+    fromMaybe "application/octet-stream" <$> getRequestHeader hContentType+  accept' ct = callr' contentTypesAccepted >>= \fs ->+    fromMaybe (errorResponse' unsupportedMediaType415) (mapContentMedia fs ct)++bool :: a -> a -> Bool -> a+bool x y p = if p then y else x++(<%%=):: MonadState s m => Lens' s a -> (a -> m a) -> m ()+l <%%= f = use l >>= f >>= assign l++encodeBodyIfSet+  :: (Applicative m, MonadReader r m, HasResourceData r m, MonadState s m, HasReqData s)+  => HaltT m ()+encodeBodyIfSet = reqDataRespBody <%%= traverse encodeBody++encodeBody+  :: (Applicative m, MonadReader r m, HasResourceData r m, MonadState s m, HasReqData s)+  => Body+  -> HaltT m Body+encodeBody = lift . encodeBody'++encodeBody'+  :: (Applicative m, MonadReader r m, HasResourceData r m, MonadState s m, HasReqData s)+  => Body+  -> m Body+encodeBody' b = do+  cs <- use reqDataRespCharset >>= \case+    Nothing -> return id+    Just cs -> callr'' charsetsProvided <&> \case+      NoCharset -> id+      CharsetsProvided cps ->+        case find ((cs ==) . fst) cps of+          Nothing -> id+          Just (_, x) -> x+  enc <- use reqDataRespEncoding >>= \case+    Nothing -> return id+    Just e -> callr'' encodingsProvided <&> \es ->+      case find ((e ==) . fst) es of+        Nothing -> id+        Just (_, x) -> x+  return $ enc $ cs b+
+ src/Webcrank/Internal/ETag.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE OverloadedStrings #-}++module Webcrank.Internal.ETag where++import Control.Applicative+import Data.Attoparsec.ByteString.Char8 (parseOnly, string)+import Data.ByteString (ByteString)++import Webcrank.Internal.Parsers+import Webcrank.Internal.Types++-- | Compares two @ETag@s for equality, only considering them equal if+-- they are both strong and byte-for-byte identical.+strongComparison :: ETag -> ETag -> Bool+strongComparison e1 e2 = case (e1, e2) of+  (StrongETag v1, StrongETag v2) -> v1 == v2+  _ -> False++-- | Compares two @ETag@s for equality, considering them equal whether or+-- not either of them is weak.+weakComparison :: ETag -> ETag -> Bool+weakComparison e1 e2 = opaqueTag e1 == opaqueTag e2++opaqueTag :: ETag -> ByteString+opaqueTag e = case e of StrongETag v -> v; WeakETag v -> v++parseETags :: ByteString -> [ETag]+parseETags = either (const[]) id . parseOnly (csl1 etagP) where+  etagP = weakP <|> strongP+  weakP = WeakETag <$> (string "W/" *> quotedStringP)+  strongP = StrongETag <$> quotedStringP+
+ src/Webcrank/Internal/Halt.hs view
@@ -0,0 +1,29 @@+{-# LANGUAGE FlexibleContexts #-}++module Webcrank.Internal.Halt where++import Control.Monad.Trans.Either+import qualified Data.ByteString.Lazy as LB+import Network.HTTP.Types++import Webcrank.Internal.Types++runHaltT :: HaltT m a -> m (Either Halt a)+runHaltT = runEitherT . unHaltT+{-# INLINE runHaltT #-}++-- | Immediately end processing of the request, returning the response+-- @Status@. It is the responsibility of the resource to ensure that all+-- necessary response header and body elements have been added in+-- order to make that response code valid.+halt :: Monad m => Status -> HaltT m a+halt = HaltT . left . Halt+{-# INLINE halt #-}++-- | Immediately end processing of this request, returning a+-- @500 Internal Server Error@ response. The response body will contain the+-- reason.+werror :: Monad m => LB.ByteString -> HaltT m a+werror = HaltT . left . Error internalServerError500+{-# INLINE werror #-}+
+ src/Webcrank/Internal/HandleRequest.hs view
@@ -0,0 +1,130 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}++module Webcrank.Internal.HandleRequest where++import qualified Blaze.ByteString.Builder as BB+import qualified Blaze.ByteString.Builder.Char.Utf8 as BB+import Control.Applicative+import Control.Lens+import Control.Monad.Catch+import Control.Monad.Reader+import Control.Monad.RWS+import Control.Monad.Trans.Maybe+import qualified Data.ByteString.Lazy as LB+import qualified Data.ByteString.Lazy.UTF8 as LB+import Data.Foldable (traverse_)+import Network.HTTP.Media+import Network.HTTP.Types++import Webcrank.Internal.DecisionCore+import Webcrank.Internal.Halt+import Webcrank.Internal.Headers+import Webcrank.Internal.Types+import Webcrank.Internal.ReqData+import Webcrank.Internal.ResourceData++-- | Process a request according to the webmachine state diagram. Intended for+-- use by server API providers. @run@ is a function which can run process to+-- completion.+--+-- @'Webcrank.ServerAPI.WebcrankT'@ is provided as a starting point. For the type+--+-- @+-- type WaiCrank = ReaderT (Request, HTTPDate) (WebcrankT IO)+-- @+--+-- an appropriate @run@ function would be+--+-- @+-- run :: Resource WaiCrank -> Request -> HTTPDate -> WaiCrank a -> IO (a, ReqData, LogData)+-- run resource req date wa = runReaderT (runWebcrankT wa (ResourceData api resource) newReqData) (req, date)+-- @+handleRequest+  :: (Applicative m, MonadReader r m, HasResourceData r m, MonadState s m, HasReqData s, MonadCatch m, Functor n)+  => (forall a. m a -> n (a, ReqData, LogData)) -- ^ run+  -> n (Status, HeadersMap, Maybe Body)+handleRequest run = run handler <&> finish where+  handler = (decisionCore <* callr'' finishRequest) `catch` handleError+  decisionCore = runHaltT (runFlowChart b13) >>= \case+    Left (Error s rs) -> s <$ prepError s rs+    Left (Halt s) -> s <$ prepResponse s+    Right s -> s <$ prepResponse s++  -- TODO log decision states+  finish (s, d, _) =+    (s, _reqDataRespHeaders d, _reqDataRespBody d)++prepResponse+  :: (Applicative m, MonadReader r m, HasResourceData r m, MonadState s m, HasReqData s)+  => Status+  -> m ()+prepResponse s = case statusCode s of+  c | c >= 400 && c < 600 -> prepError s (LB.fromStrict $ statusMessage s)+  304 -> do+    removeResponseHeader hContentType+    reqDataRespBody .= Nothing+    let header h rm = traverse_ (putResponseHeader h . renderHeader) =<< callr'' (runMaybeT . rm)+    header hETag generateETag+    header hExpires expires+  _ -> return ()++-- TODO make it customizable+prepError+  :: (Applicative m, MonadReader r m, HasResourceData r m, MonadState s m, HasReqData s)+  => Status+  -> LB.ByteString+  -> m ()+prepError s r = assign reqDataRespBody . Just =<< encodeBody' =<< renderError s r++handleError+  :: (Applicative m, MonadReader r m, HasResourceData r m, MonadState s m, HasReqData s)+  => SomeException+  -> m Status+handleError = (internalServerError500 <$) . prepError internalServerError500 . LB.fromString . show++renderError+  :: (Applicative m, MonadReader r m, HasResourceData r m, MonadState s m, HasReqData s)+  => Status+  -> LB.ByteString+  -> m Body+renderError s reason = maybe (render s reason) return =<< use reqDataRespBody where++render+  :: (Functor m, HasReqData s, HasResourceData r m, MonadReader r m, MonadState s m)+  => Status+  -> LB.ByteString+  -> m LB.ByteString+render s reason =  putResponseHeader hContentType "text/html" >> (errorBody s reason)++errorBody+  :: (Functor m, HasResourceData r m, MonadReader r m)+  => Status+  -> LB.ByteString+  -> m LB.ByteString+errorBody s reason = case statusCode s of+    404 -> return "<html><head><title>404 Not Found</title></head><body><h1>Not Found</h1>The requested document was not found on this server.<p><hr><address>webcrank web server</address></body></html>"+    500 -> return $ mconcat+      [ "<html><head><title>500 Internal Server Error</title></head><body><h1>Internal Server Error</h1>The server encountered an error while processing this request:<br><pre>"+      , reason+      , "</pre><p><hr><address>webcrank web server</address></body></html>"+      ]+    501 -> getRequestMethod' <&> \m -> mconcat+      [ "<html><head><title>501 Not Implemented</title></head><body><h1>Not Implemented</h1>The server does not support the "+      , LB.fromStrict m+      , " method.<br><p><hr><address>webmachine web server</address></body></html>"+      ]+    503 -> return "<html><head><title>503 Service Unavailable</title></head><body><h1>Service Unavailable</h1>The server is currently unable to handle the request due to a temporary overloading or maintenance of the server.<br><p><hr><address>webcrank web server</address></body></html>"+    _ -> return $ BB.toLazyByteString $ mconcat+      [ BB.fromByteString "<html><head><title>"+      , BB.fromShow $ statusCode s+      , BB.fromByteString " "+      , BB.fromByteString $ statusMessage s+      , BB.fromByteString "</title></head><body><h1>"+      , BB.fromByteString $ statusMessage s+      , BB.fromByteString "</h2>"+      , BB.fromLazyByteString reason+      , BB.fromByteString "<p><hr><address>webcrank web server</address></body></html>"+      ]+
+ src/Webcrank/Internal/Headers.hs view
@@ -0,0 +1,42 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Webcrank.Internal.Headers where++import Data.ByteString (ByteString)+import qualified Data.ByteString as B+import Data.CaseInsensitive (CI)+import qualified Data.CaseInsensitive as CI+import Network.HTTP.Date+import Network.HTTP.Media+import Network.HTTP.Types++hAcceptCharset, hAcceptEncoding, hAllow, hETag, hExpires, hIfMatch, hIfNoneMatch, hIfUnmodifiedSince, hTransferEncoding, hVary, hWWWAuthenticate :: HeaderName+hAcceptCharset = "Accept-Charset"+hAcceptEncoding = "Accept-Encoding"+hAllow = "Allow"+hETag = "ETag"+hExpires = "Expires"+hIfMatch = "If-Match"+hIfNoneMatch = "If-None-Match"+hIfUnmodifiedSince = "If-Unmodified-Since"+hTransferEncoding = "Transfer-Encoding"+hVary = "Vary"+hWWWAuthenticate = "WWW-Authenticate"++quotedString :: ByteString -> ByteString+quotedString = B.intercalate "\\\"" . B.split 34++instance RenderHeader (CI ByteString) where+  renderHeader = CI.original++instance Accept (CI ByteString) where+  parseAccept = Just . CI.mk+  matches a b = case b of+    "*" -> True+    _ -> a == b+  moreSpecificThan _ b = b == "*"++instance RenderHeader HTTPDate where+  renderHeader = formatHTTPDate
+ src/Webcrank/Internal/Parsers.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE OverloadedStrings #-}++module Webcrank.Internal.Parsers where++import Control.Applicative+import Data.Attoparsec.ByteString.Char8+import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as B+import Data.Maybe (catMaybes)+import Data.Monoid+import Prelude hiding (takeWhile)++dquote :: Char+dquote = '"'++htab :: Char+htab = '\t'++sp :: Char+sp = ' '++-- stick the hyphen at the front so we can use inClass without a range+vchar :: String+vchar = '-' : [x | x <- ['\32'..'\126'], x /= '-']++-- | Optional whitespace parser+owsP :: Parser ()+owsP = skipWhile (inClass [sp, htab]) <?> "OWS"++tokenP :: Parser ByteString+tokenP = takeWhile1 (inClass tchar) <?> "token"++tchar :: String+tchar = [x | x <- vchar, x /= sp, x `notElem` special]++special :: String+special = "()<>@,;:\\\"/[]?={}"++csl1 :: Parser a -> Parser [a]+csl1 p = (catMaybes .) . (:) <$> x <*> ys >>= failOnEmpty where+  x = optional p+  ys = many (owsP *> char ',' *> optional (owsP *> p))+  failOnEmpty xs = if null xs then fail "csl1" else pure xs++quotedStringP :: Parser ByteString+quotedStringP = dquoteP *> str <* dquoteP <?> "quoted-string" where+  str = B.concat <$> many (qdtextP <|> quotedPairP)+  qdtextP = takeWhile1 (inClass qdtext) <?> "qdtext"+  quotedPairP = char '\\' *> qc <?> "quoted-pair" where+    qc = B.singleton <$> satisfy (inClass (vchar <> [htab, sp] <> obsText))++qdtext :: String+qdtext = concat+  [ ['-', htab, sp, '!' ]+  , [x | x <- ['\x23'..'\x7E'], x /= '\\', x/= '-'] -- hyphen should only appear at beginning+  , obsText+  ]++obsText :: String+obsText = ['\x80'..'\xFF']++dquoteP :: Parser Char+dquoteP = char dquote+
+ src/Webcrank/Internal/ReqData.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}++module Webcrank.Internal.ReqData where++import Control.Applicative+import Control.Lens+import Control.Monad.State+import Data.ByteString (ByteString)+import qualified Data.ByteString.Lazy as LB+import qualified Data.HashMap.Strict as HashMap+import Data.Maybe+import Network.HTTP.Media+import Network.HTTP.Types++import Webcrank.Internal.Types++-- | Smart constructor for creating a @ReqData@ value with initial values.+newReqData :: ReqData+newReqData = ReqData+  { _reqDataDispPath = []+  , _reqDataRespMediaType = "application" // "octet-stream"+  , _reqDataRespCharset = Nothing+  , _reqDataRespEncoding = Nothing+  , _reqDataRespHeaders = HashMap.empty+  , _reqDataRespBody = Nothing+  }++-- | Lookup a response header.+getResponseHeader+  :: (Functor m, MonadState s m, HasReqData s)+  => HeaderName+  -> m (Maybe ByteString)+getResponseHeader h = (listToMaybe =<<) . HashMap.lookup h <$> use reqDataRespHeaders++-- | Replace any existing response headers for the header name with the+-- new value.+putResponseHeader+  :: (MonadState s m, HasReqData s)+  => HeaderName+  -> ByteString+  -> m ()+putResponseHeader h v = reqDataRespHeaders %= HashMap.insert h [v]++-- | Replace any existing response headers for the header name with the+-- new values.+putResponseHeaders+  :: (MonadState s m, HasReqData s)+  => ResponseHeaders+  -> m ()+putResponseHeaders = mapM_ (uncurry putResponseHeader)++-- | Remove the response header.+removeResponseHeader+  :: (MonadState s m, HasReqData s)+  => HeaderName+  -> m ()+removeResponseHeader h = reqDataRespHeaders %= HashMap.delete h++-- | Lookup the response @Location@ header.+getResponseLocation+  :: (Functor m, MonadState s m, HasReqData s)+  => m (Maybe ByteString)+getResponseLocation = getResponseHeader hLocation++-- | Set the response @Location@ header.+putResponseLocation+  :: (MonadState s m, HasReqData s)+  => ByteString+  -> m ()+putResponseLocation = putResponseHeader hLocation++-- | Use the lazy @ByteString@ as the response body.+writeLBS+  :: (MonadState s m, HasReqData s)+  => LB.ByteString+  -> m ()+writeLBS = (reqDataRespBody ?=)+
+ src/Webcrank/Internal/ResourceData.hs view
@@ -0,0 +1,71 @@+{-# LANGUAGE FlexibleContexts #-}++module Webcrank.Internal.ResourceData where++import Control.Lens+import Control.Monad.Reader+import Data.ByteString (ByteString)+import Network.HTTP.Date+import Network.HTTP.Types++import Webcrank.Internal.Types++newResourceData :: ServerAPI m -> Resource m -> ResourceData m+newResourceData = ResourceData++callr+  :: (MonadReader r m, HasResourceData r m)+  => (Resource m -> HaltT m b)+  -> HaltT m b+callr = (view resourceDataResource >>=)++callr'+  :: (MonadReader r m, HasResourceData r m)+  => (Resource m -> m b)+  -> HaltT m b+callr' = lift . (view resourceDataResource >>=)++callr''+  :: (MonadReader r m, HasResourceData r m)+  => (Resource m -> m b)+  -> m b+callr'' = (view resourceDataResource >>=)++callAPI+  :: (MonadTrans t, Monad m, MonadReader r (t m), HasResourceData r m)+  => (ServerAPI m -> m b)+  -> t m b+callAPI f = view resourceDataServerAPI >>= lift . f++callAPI'+  :: (MonadReader r m, HasResourceData r m)+  => (ServerAPI m -> m b)+  -> m b+callAPI' f = view resourceDataServerAPI >>= f++getRequestMethod+  :: (MonadTrans t, Monad m, MonadReader r (t m), HasResourceData r m)+  => t m Method+getRequestMethod = callAPI srvGetRequestMethod++getRequestMethod'+  :: (MonadReader r m, HasResourceData r m)+  => m Method+getRequestMethod' = callAPI' srvGetRequestMethod++getRequestHeader+  :: (MonadTrans t, Monad m, MonadReader r (t m), HasResourceData r m)+  => HeaderName+  -> t m (Maybe ByteString)+getRequestHeader = callAPI . flip srvGetRequestHeader++getRequestTime+  :: (MonadTrans t, Monad m, MonadReader r (t m), HasResourceData r m)+  => t m HTTPDate+getRequestTime = callAPI srvGetRequestTime++getRequestURI+  :: (MonadTrans t, Monad m, MonadReader r (t m), HasResourceData r m)+  => t m ByteString+getRequestURI = callAPI srvGetRequestURI+
+ src/Webcrank/Internal/Types.hs view
@@ -0,0 +1,308 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}++module Webcrank.Internal.Types where++import Control.Applicative+import Control.Lens+import Control.Monad.Catch+import Control.Monad.RWS+import Control.Monad.Trans.Either+import Control.Monad.Trans.Maybe+import Data.ByteString (ByteString)+import qualified Data.ByteString.Lazy as LB+import qualified Data.ByteString.UTF8 as B+import Data.CaseInsensitive (CI)+import Data.HashMap.Strict (HashMap)+import Data.List.NonEmpty (NonEmpty)+import Data.Text (Text)+import Network.HTTP.Date+import Network.HTTP.Media+import Network.HTTP.Types++import Webcrank.Internal.Headers++-- | A dictionary of functions that Webcrank needs in order to make decisions.+data ServerAPI m = ServerAPI+  { srvGetRequestMethod :: m Method+    -- ^ Get the request method of the current request.++  , srvGetRequestURI :: m ByteString+    -- ^ The full URI of the request.++  , srvGetRequestHeader :: HeaderName -> m (Maybe ByteString)+    -- ^ Get the request header of the current request.++  , srvGetRequestTime :: m HTTPDate+    -- ^ Get the time the request was received.+  }++type HeadersMap = HashMap HeaderName [ByteString]++-- | Content coding type, e.g. gzip, decompress. See @'encodingsProvided'@.+type Encoding = CI ByteString++-- | Character set type, e.g. utf-8. See @'charsetsProvided'@.+type Charset = CI ByteString++-- | Response body type.+type Body = LB.ByteString++-- | Indicates whether client is authorized to perform the requested+-- operation on the resource. See @'isAuthorized'@.+data Authorized+  = Authorized+    -- ^ Tells Webcrank that the client is authorized to perform the+    -- requested operation on the resource.+  | Unauthorized ByteString+    -- ^ Tells Webcrank that the client is not authorized to perform+    -- the operation on the resource. The value is sent in the+    -- @WWW-Authenticate@ header of the response,+    -- e.g. @Basic realm="Webcrank"@.++-- | Indicates whether the resource supports multiple character sets+-- or not.  See @'charsetsProvided'@+data CharsetsProvided+  = NoCharset+    -- ^ Indicates that the resource doesn't support any additional+    -- character sets, all responses from the resource will have the+    -- same character set, regardless of what the client requests.+  | CharsetsProvided (NonEmpty (Charset, Body -> Body))+    -- ^ The character sets the resource supports along with functions+    -- for converting the response body.++-- | Weak or strong entity tags as used in HTTP ETag and @If-*-Match@ headers.+data ETag = StrongETag ByteString | WeakETag ByteString deriving Eq++instance Show ETag where+  show e = B.toString $ case e of+    StrongETag v -> "\"" <> v <> "\""+    WeakETag v -> "W/\"" <> v <> "\""++instance RenderHeader ETag where+  renderHeader = \case+    StrongETag v -> quotedString v+    WeakETag v -> "W/" <> quotedString v++data Halt = Halt Status | Error Status LB.ByteString+  deriving (Eq, Show)++-- | Monad transformer for @'Resource'@ functions which can halt the request+-- processing early with an error or some other response. Values are created with+-- the smart constructors @'werror'@ and @'halt'@.+newtype HaltT m a = HaltT { unHaltT :: EitherT Halt m a }+  deriving+    ( Functor+    , Applicative+    , Monad+    , MonadIO+    , MonadTrans+    , MonadReader r+    , MonadState s+    , MonadWriter w+    , MonadThrow+    , MonadCatch+    )++-- | How @POST@ requests should be treated. See @'postAction'@.+data PostAction m+  = PostCreate [Text]+    -- ^ Treat @POST@s as creating new resources and respond+    -- with @201 Created@, with the given path in the Location header.+  | PostCreateRedir [Text]+    -- ^ Treat @POST@s as creating new resources and respond with+    -- @301 See Other@, redirecting the client to the new resource.+  | PostProcess (HaltT m ())+    -- ^ Treat @POST@s as a process which is executed without redirect.+  | PostProcessRedir (HaltT m ByteString)+    -- ^ Treat @POST@s as a process and redirect the client to a+    -- different (possibly new) resource.++data LogData = LogData++instance Monoid LogData where+  mempty = LogData+  mappend _ _ = LogData++-- | A @Resource@ is a dictionary of functions which are used in the Webcrank+-- decision process to determine how requests should be handled.+--+-- Each function has a type of either @m a@ or @'HaltT' m a@.+-- A resource function which yields a @HaltT m a@ value allows the function+-- to terminate the request processing early using @'halt'@ or+-- @'werror'@.+--+-- The defaults documented are used by the @'resource'@ smart constructor.+-- A resource that responds to @GET@ requests with an HTML response would be+-- written as+--+-- @+-- myResource = resource { contentTypesProvided = return $ [("text/html", return "Hello world!")] }+-- @+--+-- @'responseWithBody'@ and @'responseWithHtml'@ are additional+-- smart constructors useful creating resources.+data Resource m = Resource+  { serviceAvailable :: HaltT m Bool+    -- ^ @False@ will result in @503 Service Unavailable@. Defaults to @True@.++  , uriTooLong :: HaltT m Bool+    -- ^ @True@ will result in @414 Request Too Long@. Defaults to @False@.++  , allowedMethods :: m [Method]+    -- ^ If a @Method@ not in this list is requested, then a @405 Method Not+    -- Allowed@ will be sent. Defaults to @["GET", "HEAD"]@.++  , malformedRequest :: HaltT m Bool+    -- ^ @True@ will result in @400 Bad Request@. Defaults to @False@.++  , isAuthorized :: HaltT m Authorized+    -- ^ If @Authorized@, the response will be @401 Unauthorized@.+    -- @Unauthorized@ will be used as the challenge in the @WWW-Authenticate@+    -- header, e.g. @Basic realm="Webcrank"@.+    -- Defaults to @Authorized@.++  , forbidden :: HaltT m Bool+    -- ^ @True@ will result in @403 Forbidden@. Defaults to @False@.++  , validContentHeaders :: HaltT m Bool+    -- ^ @False@ will result in @501 Not Implemented@. Defaults to @True@.++  , knownContentType :: HaltT m Bool+    -- ^ @False@ will result in @415 Unsupported Media Type@. Defaults to+    -- @True@.++  , validEntityLength :: HaltT m Bool+    -- ^ @False@ will result in @413 Request Entity Too Large@. Defaults to+    -- @True@.++  , options :: m ResponseHeaders+    -- ^ If the OPTIONS method is supported and is used, the headers that+    -- should appear in the response. Defaults to @[]@.++  , contentTypesProvided :: m [(MediaType, HaltT m Body)]+    -- ^ Content negotiation is driven by this function. For example, if a+    -- client request includes an @Accept@ header with a value that does not+    -- appear as a @MediaType@ in any of the tuples, then a @406 Not+    -- Acceptable@ will be sent. If there is a matching @MediaType@, that+    -- function is used to create the entity when a response should include one.+    -- Defaults to @[]@.++  , charsetsProvided :: m CharsetsProvided+    -- ^ Used on GET requests to ensure that the entity is in @Charset@.+    -- Defaults to @NoCharset@.++  , encodingsProvided :: m [(Encoding, Body -> Body)]+    -- ^ Used on GET requests to ensure that the body is encoded.+    -- One useful setting is to have the function check on method, and on GET+    -- requests return @[("identity", id), ("gzip", compress)]@ as this is all+    -- that is needed to support gzip content encoding. Defaults to+    -- @[]@.++  , resourceExists :: HaltT m Bool+    -- ^ @False@ will result in @404 Not Found@. Defaults to @True@.++  , generateETag :: MaybeT m ETag+    -- ^ If this returns an @ETag@, it will be used for the ETag header and for+    -- comparison in conditional requests. Defaults to @mzero@.++  , lastModified :: MaybeT m HTTPDate+    -- ^ If this returns a @HTTPDate@, it will be used for the Last-Modified header+    -- and for comparison in conditional requests. Defaults to @mzero@.++  , expires :: MaybeT m HTTPDate+    -- ^ If this returns a @HTTPDate@, it will be used for the Expires header.+    -- Defaults to @mzero@.++  , movedPermanently :: MaybeT (HaltT m) ByteString+    -- ^ If this returns a URI, the client will receive a 301 Moved Permanently+    -- with the URI in the Location header. Defaults to @mzero@.++  , movedTemporarily :: MaybeT (HaltT m) ByteString+    -- ^ If this returns a URI, the client will receive a 307 Temporary Redirect+    -- with URI in the Location header. Defaults to @mzero@.++  , previouslyExisted :: HaltT m Bool+    -- ^ If this returns @True@, the @movedPermanently@ and @movedTemporarily@+    -- callbacks will be invoked to determine whether the response should be+    -- 301 Moved Permanently, 307 Temporary Redirect, or 410 Gone. Defaults+    -- to @False@.++  , allowMissingPost :: HaltT m Bool+    -- ^ If the resource accepts POST requests to nonexistent resources, then+    -- this should return @True@. Defaults to @False@.++  , deleteResource :: HaltT m Bool+    -- ^ This is called when a DELETE request should be enacted, and should return+    -- @True@ if the deletion succeeded or has been accepted. Defaults to+    -- @True@.++  , deleteCompleted :: HaltT m Bool+    -- ^ This is only called after a successful @deleteResource@ call, and should+    -- return @False@ if the deletion was accepted but cannot yet be guaranteed to+    -- have finished. Defaults to @True@.++  , postAction :: m (PostAction m)+    -- ^ If POST requests should be treated as a request to put content into a+    -- (potentially new) resource as opposed to being a generic submission for+    -- processing, then this function should return @PostCreate path@. If it+    -- does return @PostCreate path@, then the rest of the request will be+    -- treated much like a PUT to the path entry. Otherwise, if it returns+    -- @PostProcess a@, then the action @a@ will be run. Defaults to+    -- @PostProcess $ return ()@.++  , contentTypesAccepted :: m [(MediaType, HaltT m ())]+    -- ^ This is used similarly to @contentTypesProvided@, except that it is+    -- for incoming resource representations -- for example, @PUT@ requests.+    -- Handler functions usually want to use server specific functions to+    -- access the incoming request body. Defaults to @[]@.++  , variances :: m [HeaderName]+    -- ^ This function should return a list of strings with header names that+    -- should be included in a given response's Vary header. The standard+    -- conneg headers (Accept, Accept-Encoding, Accept-Charset,+    -- Accept-Language) do not need to be specified here as Webcrank will add+    -- the correct elements of those automatically depending on resource+    -- behavior. Defaults to @[]@.++  , multipleChoices :: HaltT m Bool+    -- ^ If this returns @True@, then it is assumed that multiple+    -- representations of the response are possible and a single one cannot+    -- be automatically chosen, so a @300 Multiple Choices@ will be sent+    -- instead of a @200 OK@. Defaults to @False@.++  , isConflict :: m Bool+    -- ^ If this returns @True@, the client will receive a 409 Conflict.+    -- Defaults to @False@.++  , finishRequest :: m ()+    -- ^ Called just before the final response is constructed and sent.+  }++-- | A wrapper for the @'ServerAPI'@ and @'Resource'@ that should be used+-- to process requests to a path.+data ResourceData m = ResourceData+  { _resourceDataServerAPI :: ServerAPI m+  , _resourceDataResource :: Resource m+  }++makeClassy ''ResourceData++-- | Container used to keep track of the decision state and what is known+-- about response while processing a request.+data ReqData = ReqData+  { _reqDataRespMediaType :: MediaType+  , _reqDataRespCharset :: Maybe Charset+  , _reqDataRespEncoding :: Maybe Encoding+  , _reqDataDispPath :: [Text]+  , _reqDataRespHeaders :: HeadersMap+  , _reqDataRespBody :: Maybe Body+  }++makeClassy ''ReqData+
+ src/Webcrank/ServerAPI.hs view
@@ -0,0 +1,17 @@+module Webcrank.ServerAPI+  ( ServerAPI(..)+  , ReqData+  , newReqData+  , HasReqData(reqData)+  , ResourceData+  , newResourceData+  , HasResourceData(resourceData)+  , LogData+  , handleRequest+  ) where++import Webcrank.Internal.HandleRequest+import Webcrank.Internal.ReqData+import Webcrank.Internal.ResourceData+import Webcrank.Internal.Types+
+ src/Webcrank/ServerAPI/WebcrankT.hs view
@@ -0,0 +1,45 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module Webcrank.ServerAPI.WebcrankT where++import Control.Applicative+import Control.Monad.Catch+import Control.Monad.Error+import Control.Monad.RWS++import Webcrank.Internal.Types++-- | Monad transformer that can be used by server API providers.+-- Provides tracking of the request state and logging of the+-- decisions made so far. For example+--+-- @+-- type WaiCrank m a = ReaderT (Request, HTTPDate) (WebcrankT m) a+-- @+--+newtype WebcrankT m a =+  WebcrankT { unWebcrankT :: RWST (ResourceData (WebcrankT m)) LogData ReqData m a }+  deriving+    ( Functor+    , Applicative+    , Monad+    , MonadIO+    , MonadReader (ResourceData (WebcrankT m))+    , MonadState ReqData+    , MonadWriter LogData+    , MonadThrow+    , MonadCatch+    , MonadMask+    )++instance MonadTrans WebcrankT where+  lift = WebcrankT . lift++runWebcrankT+  :: WebcrankT m a+  -> ServerAPI (WebcrankT m)+  -> Resource (WebcrankT m)+  -> ReqData+  -> m (a, ReqData, LogData)+runWebcrankT w s r rd = runRWST (unWebcrankT w) (ResourceData s r) rd+
+ test/tests.hs view
@@ -0,0 +1,16 @@+import Test.Tasty++import DecisionTests+import ParserTests+import HandleRequestTests++main :: IO ()+main = defaultMain tests++tests :: TestTree+tests = testGroup "Webcrank tests"+  [ parserTests+  , decisionTests+  , handleRequestTests+  ]+
+ webcrank.cabal view
@@ -0,0 +1,87 @@+name:               webcrank+version:            0.1+license:            BSD3+license-file:       LICENSE+author:             Mark Hibberd <mark@hibberd.id.au>+maintainer:         Richard Wallace <rwallace@thewallacepack.net>+copyright:          (c) 2012 Mark Hibberd+synopsis:           Webmachine inspired toolkit for building http applications and services.+category:           Web+homepage:           https://github.com/webcrank/webcrank+bug-reports:        https://github.com/webcrank/webcrank/issues+cabal-version:      >= 1.8+build-type:         Simple+description:+  Webmachine inspired toolkit for building http applications and services.++source-repository   head+  type:             git+  location:         https://github.com/webcrank/webcrank.git++flag                small_base+  description:      Choose the new, split-up base package.++library+  build-depends:    attoparsec                      >=0.10 && <0.13+                  , base                            >= 4.6 && < 5+                  , blaze-builder                   >=0.2.1.4 && <0.4+                  , bytestring                      >=0.9.1.10 && <0.11+                  , case-insensitive                >=0.3 && <1.3+                  , either                          >=3.1 && <5+                  , exceptions                      >=0.1.1 && <1+                  , http-date                       >=0.0.1 && <0.1+                  , http-media                      >=0.4.0 && <0.7+                  , http-types                      >=0.8.0 && <0.9+                  , network-uri                     >=2.5.0 && <2.7+                  , lens                            >=4.5 && <4.9+                  , mtl                             >=2.0.1 && <2.3+                  , semigroups                      >=0.8.4 && <1+                  , text                            >=0.11 && <1.3+                  , transformers                    >=0.2 && <0.5+                  , unordered-containers            ==0.2.*+                  , utf8-string                     >=0.3.1 && <1.1++  ghc-options:      -Wall++  hs-source-dirs:   src++  exposed-modules:  Webcrank+                    Webcrank.ServerAPI+                    Webcrank.ServerAPI.WebcrankT+                    Webcrank.Internal+                    Webcrank.Internal.DecisionCore+                    Webcrank.Internal.Halt++  other-modules:    Webcrank.Internal.ETag+                    Webcrank.Internal.HandleRequest+                    Webcrank.Internal.Headers+                    Webcrank.Internal.Parsers+                    Webcrank.Internal.ReqData+                    Webcrank.Internal.ResourceData+                    Webcrank.Internal.Types++test-suite tests+  type:             exitcode-stdio-1.0++  main-is:          tests.hs++  hs-source-dirs:   test++  build-depends:    QuickCheck       >= 2.4+                  , tasty            >= 0.3+                  , tasty-hunit      >= 0.2+                  , tasty-quickcheck >= 0.3++                  , attoparsec                      >=0.10 && <0.13+                  , base                            >=4.6 && < 5+                  , bytestring                      >=0.9.1.10 && <0.11+                  , case-insensitive                >=0.3 && <1.3+                  , either                          >=3.1 && <5+                  , exceptions                      >=0.1.1 && <1+                  , http-date                       >=0.0.1 && <0.1+                  , http-media                      >=0.4.0 && <0.7+                  , http-types                      >=0.8.0 && <0.9+                  , lens                            >=4.5 && <4.9+                  , mtl                             >=2.0.1 && <2.3+                  , unordered-containers            ==0.2.*+                  , webcrank