many changes

Ditz-issue: 8959dadc07db1bd363283dee401073f6e48dc7fa

diff --git a/Network/HTTP/Lucu/Interaction.hs b/Network/HTTP/Lucu/Interaction.hs
index 3508a5156c6e4f05279cdabe7fef784f8970f673..46e32a139a37d17b88b0dce43e05540dc0cbd79f 100644 (file)
--- a/Network/HTTP/Lucu/Interaction.hs
+++ b/Network/HTTP/Lucu/Interaction.hs
@@ -59,7 +59,7 @@ data Interaction = Interaction {
     , itrWillClose         ∷ !(TVar Bool)
 
     , itrBodyToSend        ∷ !(TMVar Builder)
     , itrWillClose         ∷ !(TVar Bool)
 
     , itrBodyToSend        ∷ !(TMVar Builder)

-    , itrBodyIsNull        ∷ !(TVar Bool)
+    , itrSentNoBody        ∷ !(TVar Bool)

 
     , itrState             ∷ !(TVar InteractionState)
 
 
     , itrState             ∷ !(TVar InteractionState)
 


@@ -111,7 +111,7 @@ newInteraction !conf !port !addr !cert !req
          willClose         ← newTVarIO False
 
          bodyToSend ← newEmptyTMVarIO
          willClose         ← newTVarIO False
 
          bodyToSend ← newEmptyTMVarIO

-         bodyIsNull ← newTVarIO True -- 一度でも bodyToSend が空でなくなったら False
+         sentNoBody ← newTVarIO True -- 一度でも bodyToSend が空でなくなったら False

 
          state ← newTVarIO ExaminingRequest
 
 
          state ← newTVarIO ExaminingRequest
 


@@ -145,7 +145,7 @@ newInteraction !conf !port !addr !cert !req
                     , itrWillClose         = willClose
 
                     , itrBodyToSend = bodyToSend
                     , itrWillClose         = willClose
 
                     , itrBodyToSend = bodyToSend

-                    , itrBodyIsNull = bodyIsNull
+                    , itrSentNoBody = sentNoBody

                     
                     , itrState = state
                     
                     
                     , itrState = state
                     

diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs
index a54e04061c4ca9051a9cc4f71761a748d67e1153..c8ca45d00579daff37db145dc98b217ab1f1a3d9 100644 (file)
--- a/Network/HTTP/Lucu/Resource.hs
+++ b/Network/HTTP/Lucu/Resource.hs
@@ -913,7 +913,7 @@ outputChunk wholeChunk
 
          unless (Lazy.null wholeChunk)
              $ liftIO $ atomically $
 
          unless (Lazy.null wholeChunk)
              $ liftIO $ atomically $

-               writeItr itrBodyIsNull False itr
+               writeItr itrSentNoBody False itr

     where
       sendChunks ∷ Lazy.ByteString → Int → Resource ()
       sendChunks str limit
     where
       sendChunks ∷ Lazy.ByteString → Int → Resource ()
       sendChunks str limit


@@ -977,7 +977,7 @@ driftTo newState
           = postprocess itr
 
       drift itr _ Done
           = postprocess itr
 
       drift itr _ Done

-          = do bodyIsNull ← readItr itrBodyIsNull id itr
+          = do bodyIsNull ← readItr itrSentNoBody id itr

                when bodyIsNull
                         $ writeDefaultPage itr
 
                when bodyIsNull
                         $ writeDefaultPage itr
 

diff --git a/Network/HTTP/Lucu/StaticFile.hs b/Network/HTTP/Lucu/StaticFile.hs
index 5289f5fdb8cd374c88a594e30ce0c6542e633d5a..f9e2513d47d2d865d4067f4f21e49b9a8ac972e9 100644 (file)
--- a/Network/HTTP/Lucu/StaticFile.hs
+++ b/Network/HTTP/Lucu/StaticFile.hs
@@ -1,5 +1,5 @@
 {-# LANGUAGE
 {-# LANGUAGE

-    BangPatterns
+    OverloadedStrings

   , UnicodeSyntax
   #-}
 -- | Handling static files on the filesystem.
   , UnicodeSyntax
   #-}
 -- | Handling static files on the filesystem.


@@ -13,30 +13,35 @@ module Network.HTTP.Lucu.StaticFile
     , generateETagFromFile
     )
     where
     , generateETagFromFile
     )
     where

-import           Control.Monad
-import           Control.Monad.Trans
+import qualified Blaze.ByteString.Builder.ByteString as BB
+import qualified Blaze.Text.Int as BT
+import Control.Monad
+import Control.Monad.Unicode
+import Control.Monad.Trans
+import qualified Data.Ascii as A

 import qualified Data.ByteString.Lazy.Char8 as B
 import qualified Data.ByteString.Lazy.Char8 as B

-import           Data.Time.Clock.POSIX
-import           Network.HTTP.Lucu.Abortion
-import           Network.HTTP.Lucu.Config
-import           Network.HTTP.Lucu.ETag
-import           Network.HTTP.Lucu.Format
-import           Network.HTTP.Lucu.MIMEType.Guess
-import           Network.HTTP.Lucu.Resource
-import           Network.HTTP.Lucu.Resource.Tree
-import           Network.HTTP.Lucu.Response
-import           Network.HTTP.Lucu.Utils
-import           System.FilePath.Posix
-import           System.Posix.Files
+import Data.Monoid.Unicode
+import qualified Data.Text as T
+import Data.Time.Clock.POSIX
+import Network.HTTP.Lucu.Abortion
+import Network.HTTP.Lucu.Config
+import Network.HTTP.Lucu.ETag
+import Network.HTTP.Lucu.MIMEType.Guess
+import Network.HTTP.Lucu.Resource
+import Network.HTTP.Lucu.Resource.Tree
+import Network.HTTP.Lucu.Response
+import Prelude.Unicode
+import System.FilePath
+import System.Posix.Files

 
 -- | @'staticFile' fpath@ is a 'ResourceDef' which serves the file at
 -- @fpath@ on the filesystem.
 
 -- | @'staticFile' fpath@ is a 'ResourceDef' which serves the file at
 -- @fpath@ on the filesystem.

-staticFile :: FilePath -> ResourceDef
+staticFile ∷ FilePath → ResourceDef

 staticFile path
     = ResourceDef {
         resUsesNativeThread = False
       , resIsGreedy         = False
 staticFile path
     = ResourceDef {
         resUsesNativeThread = False
       , resIsGreedy         = False

-      , resGet              = Just $! handleStaticFile path
+      , resGet              = Just $ handleStaticFile path

       , resHead             = Nothing
       , resPost             = Nothing
       , resPut              = Nothing
       , resHead             = Nothing
       , resPost             = Nothing
       , resPut              = Nothing


@@ -44,39 +49,39 @@ staticFile path
       }
 
 -- | Computation of @'handleStaticFile' fpath@ serves the file at
       }
 
 -- | Computation of @'handleStaticFile' fpath@ serves the file at

--- @fpath@ on the filesystem. The
--- 'Network.HTTP.Lucu.Resource.Resource' must be in the /Examining
+-- @fpath@ on the filesystem. The 'Resource' must be in the /Examining

 -- Request/ state before the computation. It will be in the /Done/
 -- state after the computation.
 --
 -- Request/ state before the computation. It will be in the /Done/
 -- state after the computation.
 --

--- If you just want to place a static file on the
--- 'Network.HTTP.Lucu.Resource.Tree.ResTree', you had better use
--- 'staticFile' instead of this.
-handleStaticFile :: FilePath -> Resource ()
+-- If you just want to place a static file on the 'ResTree', you had
+-- better use 'staticFile' rather than this.
+handleStaticFile ∷ FilePath → Resource ()

 handleStaticFile path
 handleStaticFile path

-    = path `seq`
-      do exists <- liftIO $ fileExist path
+    = do exists ← liftIO $ fileExist path

          if exists then
              -- 存在はした。讀めるかどうかは知らない。
          if exists then
              -- 存在はした。讀めるかどうかは知らない。

-             do stat <- liftIO $ getFileStatus path
+             do stat ← liftIO $ getFileStatus path

                 if isRegularFile stat then
                 if isRegularFile stat then

-                    do readable <- liftIO $ fileAccess path True False False
+                    do readable ← liftIO $ fileAccess path True False False

                        unless readable
                            -- 讀めない
                            $ abort Forbidden [] Nothing
                        -- 讀める
                        unless readable
                            -- 讀めない
                            $ abort Forbidden [] Nothing
                        -- 讀める

-                       tag     <- liftIO $ generateETagFromFile path
-                       let lastMod = posixSecondsToUTCTime $ fromRational $ toRational $ modificationTime stat
+                       tag ← liftIO $ generateETagFromFile path
+                       let lastMod = posixSecondsToUTCTime
+                                     $ fromRational
+                                     $ toRational
+                                     $ modificationTime stat

                        foundEntity tag lastMod
 
                        -- MIME Type を推定
                        foundEntity tag lastMod
 
                        -- MIME Type を推定

-                       conf <- getConfig
+                       conf ← getConfig

                        case guessTypeByFileName (cnfExtToMIMEType conf) path of
                        case guessTypeByFileName (cnfExtToMIMEType conf) path of

-                         Nothing   -> return ()
-                         Just mime -> setContentType mime
+                         Nothing   → return ()
+                         Just mime → setContentType mime

 
                        -- 實際にファイルを讀んで送る
 
                        -- 實際にファイルを讀んで送る

-                       liftIO (B.readFile path) >>= outputLBS
+                       liftIO (B.readFile path) ≫= output

                   else
                     abort Forbidden [] Nothing
            else
                   else
                     abort Forbidden [] Nothing
            else


@@ -95,30 +100,29 @@ handleStaticFile path
 -- as an ETag. It is indeed possible to hash it with SHA-1 or MD5 to
 -- increase strictness, but it's too inefficient if the file is really
 -- large (say, 1 TiB).
 -- as an ETag. It is indeed possible to hash it with SHA-1 or MD5 to
 -- increase strictness, but it's too inefficient if the file is really
 -- large (say, 1 TiB).

-generateETagFromFile :: FilePath -> IO ETag
+generateETagFromFile ∷ FilePath → IO ETag

 generateETagFromFile path
 generateETagFromFile path

-    = path `seq`
-      do stat <- getFileStatus path
-         let inode   = fromEnum $! fileID   stat
-             size    = fromEnum $! fileSize stat
-             lastMod = fromEnum $! modificationTime stat
-             tag     = fmtHex False 0 inode
-                       ++ "-" ++
-                       fmtHex False 0 size
-                       ++ "-" ++
-                       fmtHex False 0 lastMod
-         return $! strongETag tag
+    = do stat ← getFileStatus path
+         let inode   = fileID   stat
+             size    = fileSize stat
+             lastMod = fromEnum $ modificationTime stat
+             tag     = A.fromAsciiBuilder
+                       $ A.unsafeFromBuilder
+                       $ BT.integral inode
+                       ⊕ BB.fromByteString "-"
+                       ⊕ BT.integral size
+                       ⊕ BB.fromByteString "-"
+                       ⊕ BT.integral lastMod
+         return $ strongETag tag

 
 

--- | @'staticDir' dir@ is a
--- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef' which maps all files
--- in @dir@ and its subdirectories on the filesystem to the
--- 'Network.HTTP.Lucu.Resource.Tree.ResTree'.
-staticDir :: FilePath -> ResourceDef
+-- | @'staticDir' dir@ is a 'ResourceDef' which maps all files in
+-- @dir@ and its subdirectories on the filesystem to the 'ResTree'.
+staticDir ∷ FilePath → ResourceDef

 staticDir path
     = ResourceDef {
         resUsesNativeThread = False
       , resIsGreedy         = True
 staticDir path
     = ResourceDef {
         resUsesNativeThread = False
       , resIsGreedy         = True

-      , resGet              = Just $! handleStaticDir path
+      , resGet              = Just $ handleStaticDir path

       , resHead             = Nothing
       , resPost             = Nothing
       , resPut              = Nothing
       , resHead             = Nothing
       , resPost             = Nothing
       , resPut              = Nothing


@@ -126,25 +130,21 @@ staticDir path
       }
 
 -- | Computation of @'handleStaticDir' dir@ maps all files in @dir@
       }
 
 -- | Computation of @'handleStaticDir' dir@ maps all files in @dir@

--- and its subdirectories on the filesystem to the
--- 'Network.HTTP.Lucu.Resource.Tree.ResTree'. The
--- 'Network.HTTP.Lucu.Resource.Resource' must be in the /Examining
--- Request/ state before the computation. It will be in the /Done/
--- state after the computation.
+-- and its subdirectories on the filesystem to the 'ResTree'. The
+-- 'Resource' must be in the /Examining Request/ state before the
+-- computation. It will be in the /Done/ state after the computation.

 --
 --

--- If you just want to place a static directory tree on the
--- 'Network.HTTP.Lucu.Resource.Tree.ResTree', you had better use
--- 'staticDir' instead of this.
-handleStaticDir :: FilePath -> Resource ()
-handleStaticDir !basePath
-    = do extraPath <- getPathInfo
+-- If you just want to place a static directory tree on the 'ResTree',
+-- you had better use 'staticDir' rather than this.
+handleStaticDir ∷ FilePath → Resource ()
+handleStaticDir basePath
+    = do extraPath ← getPathInfo

          securityCheck extraPath
          securityCheck extraPath

-         let path = basePath </> joinPath extraPath
+         let path = basePath </> joinPath (map T.unpack extraPath)

 
          handleStaticFile path
     where
 
          handleStaticFile path
     where

-      securityCheck :: Monad m => [String] -> m ()
-      securityCheck !pathElems
-          = when (any (== "..") pathElems) $ fail ("security error: "
-                                                   ++ joinWith "/" pathElems)
+      securityCheck pathElems
+          = when (any (≡ "..") pathElems)
+                $ fail ("security error: " ⧺ show pathElems)

 -- TODO: implement directory listing.
 -- TODO: implement directory listing.