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
-> m (FlowChart m a)
-> FlowChart m a
decision = Decision
decision'
:: Functor m
=> String
-> m Bool
-> FlowChart m a
-> FlowChart m a
-> 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)
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
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
knownMethods = [methodGet, methodHead, methodPost, methodPut, methodDelete, methodTrace, methodConnect, methodOptions]
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)
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
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)
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
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)
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
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
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
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
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
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"
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
d5
:: (Applicative m, MonadReader r m, HasResourceData r m, MonadState s m, HasReqData s)
=> ByteString
-> FlowChart (HaltT m) Status
d5 _ = decision "d5" $ return e5
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)
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"
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
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
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]
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
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 == "*")
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)
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
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
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
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)
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
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
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
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 == "*")
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])
k5
:: (Applicative m, MonadReader r m, HasResourceData r m, MonadState s m, HasReqData s)
=> FlowChart (HaltT m) Status
k5 = decision "k5" $ movedPermanentlyOr l5
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
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
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
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
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
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
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
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)
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
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
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
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
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
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
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
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
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
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
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
p3
:: (Applicative m, MonadReader r m, HasResourceData r m, MonadState s m, HasReqData s)
=> FlowChart (HaltT m) Status
p3 = decision "p3" isConflict'
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