module WebWire.Routing
(
directory,
file,
rootDir,
redirect,
redirectRaw,
seeOther,
seeOtherRaw,
cdIn,
cdOut,
currentDir,
currentPath,
pathAbs,
pathRel,
requestDir,
requestPath,
rootPath,
setRoot
)
where
import qualified Data.Text as T
import Control.Monad.Trans.State
import Data.Text (Text)
import FRP.NetWire
import Network.HTTP.Types
import WebWire.Tools
import WebWire.Types
cdIn :: WebWire site a ()
cdIn =
proc _ -> do
reqPath <- requestPath -< ()
case reqPath of
[] -> notFound -< ()
reqDir : restPath -> do
execute -<
modify $ \cfg ->
let curPath = wcCurrentPath cfg
in cfg { wcCurrentPath = reqDir : curPath,
wcRequestPath = restPath }
cdOut :: WebWire site a ()
cdOut =
proc _ -> do
curPath <- currentPath -< ()
case curPath of
[] -> notFound -< ()
curDir : restPath -> do
execute -<
modify $ \cfg ->
let reqPath = wcRequestPath cfg
in cfg { wcCurrentPath = restPath,
wcRequestPath = curDir : reqPath }
currentDir :: WebWire site a (Maybe Text)
currentDir =
proc _ -> do
curPath <- currentPath -< ()
identity -<
case curPath of
[] -> Nothing
(dir:_) -> Just dir
currentPath :: WebWire site a [Text]
currentPath =
proc _ -> execute -< gets wcCurrentPath
directory :: Text -> WebWire site a b -> WebWire site a b
directory dir localWire =
proc x' -> do
mReqDir <- requestDir -< ()
if maybe True (/= dir) mReqDir
then notFound -< ()
else do
cdIn -< ()
mx <- exhibit localWire -< x'
cdOut -< ()
inject -< mx
file :: Text -> WebWire site a b -> WebWire site a b
file fn localWire =
proc x' -> do
reqPath <- requestPath -< ()
case reqPath of
[seg] | seg == fn -> do
cdIn -< ()
mx <- exhibit localWire -< x'
cdOut -< ()
inject -< mx
_ -> notFound -< ()
pathAbs :: WebWire site [Text] Text
pathAbs =
proc path -> do
rp <- rootPath -< ()
identity -< T.intercalate "/" . foldl (\es e -> e:es) path $ rp
pathRel :: WebWire site [Text] Text
pathRel =
proc path -> do
curPath <- currentPath -< ()
identity -< T.intercalate "/" . foldl (\es e -> e:es) path $ curPath
redirect :: RedirectType -> WebWire site Text b
redirect redirType =
proc path ->
redirectRaw redirType -< path
redirectRaw :: RedirectType -> WebWire site Text b
redirectRaw redirType =
proc path -> do
let status = case redirType of
RedirectPermanent -> statusMovedPermanently
RedirectSeeOther -> statusSeeOther
RedirectTemporary -> Status 307 "Temporary redirect"
inhibit -< WebRedirect status path
requestDir :: WebWire site a (Maybe Text)
requestDir =
proc _ -> do
reqPath <- requestPath -< ()
identity -<
case reqPath of
[] -> Nothing
(dir:_) -> Just dir
requestPath :: WebWire site a [Text]
requestPath =
proc _ -> execute -< gets wcRequestPath
rootDir :: WebWire site a b -> WebWire site a b
rootDir localWire =
proc x' -> do
reqPath <- requestPath -< ()
if null reqPath
then localWire -< x'
else notFound -< ()
rootPath :: WebWire site a [Text]
rootPath =
proc _ -> execute -< gets wcRootPath
seeOther :: WebWire site Text b
seeOther = redirect RedirectSeeOther
seeOtherRaw :: WebWire site Text b
seeOtherRaw = redirectRaw RedirectSeeOther
setRoot :: WebWire site [Text] ()
setRoot =
proc path ->
execute -< modify (\cfg -> cfg { wcCurrentPath = path,
wcRootPath = path })