webwire-0.1.0: WebWire/Routing.hs

-- |
-- Module:     WebWire.Routing
-- Copyright:  (c) 2011 Ertugrul Soeylemez
-- License:    BSD3
-- Maintainer: Ertugrul Soeylemez <es@ertes.de>
--
-- Routing functionality.

module WebWire.Routing
    ( -- * Routing
      directory,
      file,
      rootDir,

      -- * Redirecting
      redirect,
      redirectRaw,
      seeOther,
      seeOtherRaw,

      -- * Paths
      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


-- | Remove the root request segment and add it to the current path.
-- Inhibits with a 404 error, if the request path is empty.

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 }


-- | Remove the current tail segment and add it to the request path.
-- Inhibits with a 404 error, if the current path is empty.

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 }


-- | Output the current path segment, if there is one.  Outputs
-- 'Nothing', if there are no further path segments.  In particular, if
-- the root path is requested, this wire always returns 'Nothing'.

currentDir :: WebWire site a (Maybe Text)
currentDir =
    proc _ -> do
        curPath <- currentPath -< ()
        identity -<
            case curPath of
              []      -> Nothing
              (dir:_) -> Just dir


-- | Output the current rest of the path segment.

currentPath :: WebWire site a [Text]
currentPath =
    proc _ -> execute -< gets wcCurrentPath


-- | If the request root segment is the given directory, then removes
-- the root segment and adds it to the current path for the given wire.

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


-- | If the request root segment is the given file and there are no more
-- segments, then removes the last segment and adds it to the current
-- path for the given wire.

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 -< ()


-- | Construct the full URI to the given path from the root path.

pathAbs :: WebWire site [Text] Text
pathAbs =
    proc path -> do
        rp <- rootPath -< ()
        identity -< T.intercalate "/" . foldl (\es e -> e:es) path $ rp


-- | Construct the full URI to the given path from the current path.

pathRel :: WebWire site [Text] Text
pathRel =
    proc path -> do
        curPath <- currentPath -< ()
        identity -< T.intercalate "/" . foldl (\es e -> e:es) path $ curPath


-- | Redirect to the input URI.  Inhibits with the appropriate
-- exception.

redirect :: RedirectType -> WebWire site Text b
redirect redirType =
    proc path ->
        redirectRaw redirType -< path


-- | Redirect to the input URI.  Inhibits with the appropriate
-- exception.

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


-- | Output the root request path segment, if there is one.  Outputs
-- 'Nothing', if there are no further path segments.  In particular, if
-- the root path is requested, this wire always returns 'Nothing'.

requestDir :: WebWire site a (Maybe Text)
requestDir =
    proc _ -> do
        reqPath <- requestPath -< ()
        identity -<
            case reqPath of
              []      -> Nothing
              (dir:_) -> Just dir


-- | Output the rest of the request path segment.

requestPath :: WebWire site a [Text]
requestPath =
    proc _ -> execute -< gets wcRequestPath


-- | Run the given wire, if the current request path is empty.
-- Otherwise inhibit with 404.

rootDir :: WebWire site a b -> WebWire site a b
rootDir localWire =
    proc x' -> do
        reqPath <- requestPath -< ()
        if null reqPath
          then localWire -< x'
          else notFound -< ()


-- | Output the current root path.

rootPath :: WebWire site a [Text]
rootPath =
    proc _ -> execute -< gets wcRootPath


-- | Convenience interface to 'redirect' for the very common 303
-- redirection.

seeOther :: WebWire site Text b
seeOther = redirect RedirectSeeOther


-- | Convenience interface to 'redirect' for the very common 303
-- redirection.

seeOtherRaw :: WebWire site Text b
seeOtherRaw = redirectRaw RedirectSeeOther


-- | Set the current root path.  This wire also resets the current path.

setRoot :: WebWire site [Text] ()
setRoot =
    proc path ->
        execute -< modify (\cfg -> cfg { wcCurrentPath = path,
                                         wcRootPath = path })