X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FResource%2FInternal.hs;h=1993eb251deafdb09dbb98f0916601b581dc5a15;hb=c9a269666f2d60d9c5ba817e1c43b45f6d77de22;hp=f6d17b6b2f367e32d4956cdccd68431165414db2;hpb=3baf479eba12bc3e9c4ef966df770cd70aa5cd81;p=Lucu.git

diff --git a/Network/HTTP/Lucu/Resource/Internal.hs b/Network/HTTP/Lucu/Resource/Internal.hs
index f6d17b6..1993eb2 100644
--- a/Network/HTTP/Lucu/Resource/Internal.hs
+++ b/Network/HTTP/Lucu/Resource/Internal.hs
@@ -38,19 +38,20 @@ import Control.Concurrent
 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.Convertible.Instances.Text ()
 import Data.List (intersperse, nub)
 import Data.Maybe
 import Data.Monoid
 import Data.Monoid.Unicode
-import qualified Data.Text as T
 import Network.HTTP.Lucu.Abortion
 import Network.HTTP.Lucu.Abortion.Internal
 import Network.HTTP.Lucu.Config
@@ -75,7 +76,7 @@ newtype Rsrc a
     = 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
@@ -179,10 +180,10 @@ spawnRsrc (Resource {..}) ni@(NI {..})
       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"]
@@ -201,7 +202,7 @@ spawnRsrc (Resource {..}) ni@(NI {..})
       toAbortion e
           = case fromException e of
               Just abortion → abortion
-              Nothing       → mkAbortion' InternalServerError $ T.pack $ show e
+              Nothing       → mkAbortion' InternalServerError $ cs $ show e
 
       processException ∷ SomeException → IO ()
       processException exc
@@ -261,25 +262,30 @@ getRequest ∷ Rsrc Request
 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
 
@@ -330,7 +336,7 @@ setStatus sc
 -- |@'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
@@ -375,8 +381,8 @@ deleteHeader name = liftIO ∘ atomically ∘ go =≪ getInteraction
 -- 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