1 {-# LANGUAGE OverloadedStrings #-} 2 module Databrary.HTTP.Request 3 ( Wai.Request 4 , MonadHasRequest 5 , lookupRequestHeader 6 , lookupRequestHeaders 7 , lookupQueryParameters 8 , boolParameterValue 9 , boolQueryParameter 10 , requestHost 11 , requestURI 12 ) where 13 14 import qualified Data.ByteString as BS 15 import qualified Data.ByteString.Char8 as BSC 16 import Data.Maybe (fromMaybe) 17 import Data.Monoid ((<>)) 18 import Network.HTTP.Types (HeaderName) 19 import Network.URI (URI(..), URIAuth(..)) 20 import qualified Network.Wai as Wai 21 22 import Databrary.Has (MonadHas) 23 24 type MonadHasRequest c m = MonadHas Wai.Request c m 25 26 lookupRequestHeader :: HeaderName -> Wai.Request -> Maybe BS.ByteString 27 lookupRequestHeader h = lookup h . Wai.requestHeaders 28 29 lookupRequestHeaders :: HeaderName -> Wai.Request -> [BS.ByteString] 30 lookupRequestHeaders h = map snd . filter ((h ==) . fst) . Wai.requestHeaders 31 32 lookupQueryParameters :: BS.ByteString -> Wai.Request -> [Maybe BS.ByteString] 33 lookupQueryParameters q = map snd . filter ((q ==) . fst) . Wai.queryString 34 35 boolValue :: BS.ByteString -> Bool 36 boolValue "0" = False 37 boolValue "false" = False 38 boolValue "off" = False 39 boolValue "" = False 40 boolValue _ = True 41 42 boolParameterValue :: Maybe BS.ByteString -> Bool 43 boolParameterValue = all boolValue 44 45 boolQueryParameter :: BS.ByteString -> Wai.Request -> Bool 46 boolQueryParameter q = any boolParameterValue . lookupQueryParameters q 47 48 defaultHost :: BS.ByteString 49 defaultHost = "databrary.org" 50 51 requestHost :: Wai.Request -> BS.ByteString 52 requestHost req = 53 (if Wai.isSecure req then "https://" else "http://") 54 <> fromMaybe "databrary.org" (Wai.requestHeaderHost req) 55 56 requestURI :: Wai.Request -> URI 57 requestURI req = URI 58 { uriScheme = if Wai.isSecure req then "https:" else "http:" 59 , uriAuthority = Just URIAuth 60 { uriUserInfo = "" 61 , uriRegName = BSC.unpack $ fromMaybe defaultHost $ Wai.requestHeaderHost req 62 , uriPort = "" 63 } 64 , uriPath = BSC.unpack $ Wai.rawPathInfo req 65 , uriQuery = BSC.unpack $ Wai.rawQueryString req 66 , uriFragment = "" 67 }