module Airship.Internal.Helpers where
#if __GLASGOW_HASKELL__ < 710
import Control.Applicative
#endif
import Data.ByteString (ByteString)
import qualified Data.ByteString.Lazy as LazyBS
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 Lens.Micro ((^.))
import Network.HTTP.Media
import qualified Network.HTTP.Types as HTTP
import qualified Network.Wai as Wai
import Network.Wai.Parse
import System.Random
import Airship.Config
import Airship.Headers
import Airship.Internal.Decision
import Airship.Internal.Route
import Airship.Resource
import Airship.Types
parseFormData :: Request -> IO ([Param], [File LazyBS.ByteString])
parseFormData r = parseRequestBody lbsBackEnd r
contentTypeMatches :: Monad m => [MediaType] -> Webmachine 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
redirectTemporarily :: Monad m => ByteString -> Webmachine m a
redirectTemporarily location =
addResponseHeader ("Location", location) >> halt HTTP.status302
redirectPermanently :: Monad m => ByteString -> Webmachine m a
redirectPermanently location =
addResponseHeader ("Location", location) >> halt HTTP.status301
toWaiResponse :: Response -> AirshipConfig -> ByteString -> ByteString -> Wai.Response
toWaiResponse Response{..} cfg trace quip =
case _responseBody of
(ResponseBuilder b) ->
Wai.responseBuilder _responseStatus headers b
(ResponseFile path part) ->
Wai.responseFile _responseStatus headers path part
(ResponseStream streamer) ->
Wai.responseStream _responseStatus headers streamer
Empty ->
Wai.responseBuilder _responseStatus headers mempty
where
headers = traced ++ quipHeader ++ _responseHeaders
traced = if cfg^.includeTraceHeader == IncludeHeader
then [("Airship-Trace", trace)]
else []
quipHeader = if cfg^.includeQuipHeader == IncludeHeader
then [("Airship-Quip", quip)]
else []
resourceToWai :: AirshipConfig -> RoutingSpec IO () -> Resource IO -> Wai.Application
resourceToWai cfg routes resource404 =
resourceToWaiT cfg (const id) routes resource404
resourceToWaiT :: Monad m => AirshipConfig -> (Request -> m Wai.Response -> IO Wai.Response) -> RoutingSpec m () -> Resource m -> Wai.Application
resourceToWaiT cfg run routes resource404 req respond = do
let routeMapping = runRouter routes
pInfo = Wai.pathInfo req
(resource, (params', matched)) = route routeMapping pInfo resource404
nowTime <- getCurrentTime
quip <- getQuip
(=<<) respond . run req $ do
(response, trace) <- eitherResponse nowTime params' matched req (flow resource)
return $ toWaiResponse response cfg (traceHeader trace) 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"
, "shut it down"
]
traceHeader :: [Text] -> ByteString
traceHeader = encodeUtf8 . intercalate ","