X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FImplant.hs;fp=Network%2FHTTP%2FLucu%2FImplant.hs;h=f80ac99cfdbc768bcb0f931ed50f0058b1364129;hb=cc074d0ce3f7df2544bc2baddca4e7730ecdf0a0;hp=0000000000000000000000000000000000000000;hpb=4e41b11200285142757434e9d67e17ed20fae455;p=Lucu.git

diff --git a/Network/HTTP/Lucu/Implant.hs b/Network/HTTP/Lucu/Implant.hs
new file mode 100644
index 0000000..f80ac99
--- /dev/null
+++ b/Network/HTTP/Lucu/Implant.hs
@@ -0,0 +1,98 @@
+{-# LANGUAGE
+    QuasiQuotes
+  , RecordWildCards
+  , UnicodeSyntax
+  #-}
+-- |An internal module for generating Haskell modules eith an
+-- arbitrary file implanted.
+module Network.HTTP.Lucu.Implant
+    ( Input(..)
+
+    , originalLen
+    , gzippedLen
+    , useGZip
+
+    , openInput
+    )
+    where
+import Codec.Compression.GZip
+import Control.Applicative
+import qualified Data.Ascii as A
+import qualified Data.ByteString.Lazy as L
+import Data.Digest.Pure.SHA
+import Data.Maybe
+import Data.Time
+import Data.Time.Clock.POSIX
+import Network.HTTP.Lucu.ETag
+import Network.HTTP.Lucu.MIMEType hiding (mimeType)
+import Network.HTTP.Lucu.MIMEType.DefaultExtensionMap
+import Network.HTTP.Lucu.MIMEType.Guess
+import Network.HTTP.Lucu.MIMEType.TH
+import Prelude.Unicode
+import System.Posix.Files
+
+data Input
+    = Input {
+        iPath    ∷ !FilePath
+      , iLastMod ∷ !UTCTime
+      , iType    ∷ !MIMEType
+      , iETag    ∷ !ETag
+      , iRawData ∷ !L.ByteString
+      , iGZipped ∷ !L.ByteString
+      }
+
+originalLen ∷ Input → Integer
+originalLen (Input {..})
+    = fromIntegral $ L.length iRawData
+
+gzippedLen ∷ Input → Integer
+gzippedLen (Input {..})
+    = fromIntegral $ L.length iGZipped
+
+useGZip ∷ Input → Bool
+useGZip i
+    = originalLen i ≥ gzippedLen i
+
+openInput ∷ FilePath → Maybe MIMEType → Maybe ETag → IO Input
+openInput fpath ctype etag
+    = do lastMod ← lastModified fpath
+         input   ← openInputFile fpath
+         return Input {
+                  iPath    = fpath
+                , iLastMod = lastMod
+                , iType    = fromMaybe octetStream
+                             $ ctype <|> guessType fpath
+                , iETag    = fromMaybe (mkETagFromInput input) etag
+                , iRawData = input
+                , iGZipped = compressWith compParams input
+                }
+    where
+      octetStream ∷ MIMEType
+      octetStream = [mimeType| application/octet-stream |]
+
+      compParams ∷ CompressParams
+      compParams = defaultCompressParams {
+                     compressLevel = bestCompression
+                   }
+
+lastModified ∷ FilePath → IO UTCTime
+lastModified "-"   = getCurrentTime
+lastModified fpath = ( posixSecondsToUTCTime
+                     ∘ fromRational
+                     ∘ toRational
+                     ∘ modificationTime
+                     )
+                     <$>
+                     getFileStatus fpath
+
+openInputFile ∷ FilePath → IO L.ByteString
+openInputFile "-"   = L.getContents
+openInputFile fpath = L.readFile fpath
+
+guessType ∷ FilePath → Maybe MIMEType
+guessType = guessTypeByFileName defaultExtensionMap
+
+mkETagFromInput ∷ L.ByteString → ETag
+mkETagFromInput input
+    = strongETag $ A.unsafeFromString
+                 $ "SHA-1:" ⧺ showDigest (sha1 input)