import Control.Concurrent.STM
import Control.Exception
import Control.Monad hiding (mapM_)
+import Control.Monad.Fix
import Control.Monad.IO.Class
import Control.Monad.Reader (ReaderT, runReaderT, ask)
import Control.Monad.Unicode
-import Data.Ascii (Ascii, CIAscii)
-import qualified Data.Ascii as A
+import Data.Ascii (Ascii, CIAscii, AsciiBuilder)
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import Data.Collections
+import Data.Convertible.Base
import Data.List (intersperse, nub)
import Data.Maybe
import Data.Monoid
= Rsrc {
unRsrc ∷ ReaderT NormalInteraction IO a
}
- deriving (Applicative, Functor, Monad, MonadIO)
+ deriving (Applicative, Functor, Monad, MonadFix, MonadIO)
runRsrc ∷ Rsrc a → NormalInteraction → IO a
runRsrc = runReaderT ∘ unRsrc
notAllowed ∷ Rsrc ()
notAllowed = do setStatus MethodNotAllowed
setHeader "Allow"
- $ A.fromAsciiBuilder
+ $ cs
$ mconcat
- $ intersperse (A.toAsciiBuilder ", ")
- $ map A.toAsciiBuilder allowedMethods
+ $ intersperse (cs (", " ∷ Ascii) ∷ AsciiBuilder)
+ $ map cs allowedMethods
allowedMethods ∷ [Ascii]
allowedMethods = nub $ concat [ methods resGet ["GET"]
getRequest = niRequest <$> getInteraction
-- |Get the path of this 'Rsrc' (to be exact, 'Resource') in the
--- 'Network.HTTP.Lucu.Resource.Tree.ResTree'. The result of this
+-- corresponding 'Network.HTTP.Lucu.ResourceTree'. The result of this
-- action is the exact path in the tree even when the 'Resource' is
--- greedy.
+-- 'Network.HTTP.Lucu.greedy'.
--
-- Example:
--
--- > main = let tree = mkResTree [ (["foo"], resFoo) ]
--- > in runHttpd defaultConfig tree []
--- >
--- > resFoo = emptyResource {
--- > resIsGreedy = True
--- > , resGet = Just $ do requestURI <- getRequestURI
--- > resourcePath <- getResourcePath
--- > pathInfo <- getPathInfo
--- > -- uriPath requestURI == "/foo/bar/baz"
--- > -- resourcePath == ["foo"]
--- > -- pathInfo == ["bar", "baz"]
--- > ...
--- > }
+-- @
+-- main :: 'IO' ()
+-- main = let tree :: 'Network.HTTP.Lucu.ResourceTree'
+-- tree = 'fromList' [ (["foo"], 'Network.HTTP.Lucu.greedy' resFoo) ]
+-- in 'Network.withSocketsDo' '.' 'Network.HTTP.Lucu.runHttpd' 'defaultConfig' $ 'Network.HTTP.Lucu.resourceMap' tree
+--
+-- resFoo :: 'Resource'
+-- resFoo = 'singleton'
+-- ( 'GET'
+-- , do requestURI <- 'getRequestURI'
+-- resourcePath <- 'getResourcePath'
+-- pathInfo <- 'getPathInfo'
+-- -- 'Network.URI.uriPath' requestURI '==' \"/foo/bar/baz\"
+-- -- resourcePath == ["foo"]
+-- -- pathInfo == ["bar", "baz"]
+-- ...
+-- )
+-- @
getResourcePath ∷ Rsrc Path
getResourcePath = niResourcePath <$> getInteraction
-- |@'setHeader' name value@ declares the value of the response header
-- @name@ as @value@. Note that this function is not intended to be
-- used so frequently: there should be specialised functions like
--- 'setContentType' for every common headers.
+-- 'Network.HTTP.Lucu.setContentType' for every common headers.
--
-- Some important headers (especially \"Content-Length\" and
-- \"Transfer-Encoding\") may be silently dropped or overwritten by
-- infinitely long stream of octets.
--
-- Note that you must first declare the response header
--- \"Content-Type\" before applying this function. See:
--- 'setContentType'
+-- \"Content-Type\" before applying this function. See
+-- 'Network.HTTP.Lucu.setContentType'.
putBuilder ∷ Builder → Rsrc ()
putBuilder b = liftIO ∘ atomically ∘ go =≪ getInteraction
where