merge branch origin/master

[Rakka.git] / Rakka / Utils.hs

diff --git a/Rakka/Utils.hs b/Rakka/Utils.hs
index 4da609cd48b0baf42d015c3975f2644a2190f2da..717a6068bddfa332b8dddb1edbcd94dc8ed39891 100644 (file)
--- a/Rakka/Utils.hs
+++ b/Rakka/Utils.hs
@@ -1,76 +1,133 @@
+{-# LANGUAGE
+    Arrows
+  , OverloadedStrings
+  , TypeOperators
+  , UnicodeSyntax
+  #-}
 module Rakka.Utils
-    ( parseYesOrNo
+    ( yesOrNo
+    , trueOrFalse
+    , parseYesOrNo
     , maybeA
-    , defaultTo
     , deleteIfEmpty
-    , formatW3CDateTime
+    , chomp
+    , guessMIMEType
+    , isSafeChar
+    , mkQueryString
     )
     where
+import Control.Arrow
+import Control.Arrow.ArrowList
+import Data.ByteString (ByteString)
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Char8 as C8
+import qualified Data.ByteString.Lazy as LS
+import qualified Data.ByteString.Unsafe as BS
+import Data.Char
+import Data.Monoid.Unicode
+import Data.String
+import Data.Text (Text)
+import Data.Text.Encoding
+import Magic
+import Network.HTTP.Lucu
+import Network.URI
+import Numeric
+import Prelude.Unicode
+import System.IO.Unsafe
 
-import           Control.Arrow
-import           Control.Arrow.ArrowList
-import           System.Time
-import           Text.Printf
+yesOrNo ∷ Bool → String
+yesOrNo True  = "yes"
+yesOrNo False = "no"
 
+trueOrFalse ∷ Bool → String
+trueOrFalse True  = "true"
+trueOrFalse False = "false"
 
-parseYesOrNo :: ArrowChoice a => a String Bool
-parseYesOrNo 
-    = proc str -> do case str of
-                       "yes" -> returnA -< True
-                       "no"  -> returnA -< False
-                       _     -> returnA -< error ("Expected yes or no: " ++ str)
-
+parseYesOrNo ∷ (Eq s, Show s, IsString s, ArrowChoice (⇝)) ⇒ s ⇝ Bool
+parseYesOrNo = arr f
+    where
+      f "yes" = True
+      f "no"  = False
+      f str   = error ("Expected yes or no: " ⊕ show str)
 
-maybeA :: (ArrowList a, ArrowChoice a) => a b c -> a b (Maybe c)
+maybeA ∷ (ArrowList a, ArrowChoice a) ⇒ a b c → a b (Maybe c)
 maybeA a = listA a
            >>>
-           proc xs -> case xs of
-                        []    -> returnA -< Nothing
-                        (x:_) -> returnA -< Just x
+           proc xs → case xs of
+                        []    → returnA ⤙ Nothing
+                        (x:_) → returnA ⤙ Just x
 
+deleteIfEmpty ∷ (ArrowList a, ArrowChoice a) ⇒ a String String
+deleteIfEmpty
+    = proc str → do case str of
+                       "" → none    ⤙ ()
+                       _  → returnA ⤙ str
 
-defaultTo :: ArrowChoice a => b -> a (Maybe b) b
-defaultTo def
-    = proc m -> case m of
-                  Nothing -> returnA -< def
-                  Just x  -> returnA -< x
+chomp ∷ String → String
+{-# INLINE chomp #-}
+chomp = reverse . snd . break (≢ '\n') . reverse
 
+guessMIMEType ∷ LS.ByteString → MIMEType
+{-# INLINEABLE guessMIMEType #-}
+guessMIMEType = read
+                ∘ unsafePerformIO
+                ∘ flip BS.unsafeUseAsCStringLen (magicCString magic)
+                ∘ BS.concat
+                ∘ LS.toChunks
+    where
+      magic ∷ Magic
+      {-# NOINLINE magic #-}
+      magic = unsafePerformIO
+              $ do m ← magicOpen [MagicMime]
+                   magicLoadDefault m
+                   return m
 
-deleteIfEmpty :: (ArrowList a, ArrowChoice a) => a String String
-deleteIfEmpty
-    = proc str -> do case str of
-                       "" -> none    -< ()
-                       _  -> returnA -< str
+isSafeChar ∷ Char → Bool
+{-# INLINEABLE isSafeChar #-}
+isSafeChar c
+    | c ≡ '/'           = True
+    | isReserved c      = False
+    | c > ' ' ∧ c ≤ '~' = True
+    | otherwise         = False
 
+mkQueryString ∷ [(Text, Text)] → ByteString
+{-# INLINEABLE mkQueryString #-}
+mkQueryString = BS.intercalate (C8.singleton ';') ∘ map encodePair
+    where
+      encodePair ∷ (Text, Text) → ByteString
+      {-# INLINE encodePair #-}
+      encodePair (k, v)
+          = BS.intercalate (C8.singleton '=') [encodeText k, encodeText v]
+
+      encodeText ∷ Text → ByteString
+      {-# INLINE encodeText #-}
+      encodeText = toURLEncoded ∘ encodeUtf8
 
-formatW3CDateTime :: CalendarTime -> String
-formatW3CDateTime time
-    = formatDateTime time ++ formatTimeZone time
+toURLEncoded ∷ ByteString → ByteString
+{-# INLINEABLE toURLEncoded #-}
+toURLEncoded = C8.concatMap go
     where
-      formatDateTime :: CalendarTime -> String
-      formatDateTime time
-          = printf "%04d-%02d-%02dT%02d:%02d:%02d"
-            (ctYear time)
-            (fromEnum (ctMonth time) + 1)
-            (ctDay  time)
-            (ctHour time)
-            (ctMin  time)
-            (ctSec  time)
-      
-      formatTimeZone :: CalendarTime -> String
-      formatTimeZone time
-          = case ctTZ time
-            of offset | offset <  0 -> '-':(showTZ $ negate offset)
-                      | offset == 0 -> "Z"
-                      | otherwise   -> '+':(showTZ offset)
-      
-      showTZ :: Int -> String   
-      showTZ offset
-          = let hour = offset `div` 3600
-                min  = (offset - hour * 3600) `div` 60
-            in 
-              show2 hour ++ ":" ++ show2 min
-            
-      show2 :: Int -> String
-      show2 n | n < 10    = '0':(show n)
-              | otherwise = show n
\ No newline at end of file
+      go ∷ Char → ByteString
+      {-# INLINE go #-}
+      go c | c ≡ ' '        = C8.singleton '+'
+           | isReserved   c = urlEncode c
+           | isUnreserved c = C8.singleton c
+           | otherwise      = urlEncode c
+
+      urlEncode ∷ Char → ByteString
+      {-# INLINE urlEncode #-}
+      urlEncode c = C8.pack ('%':toHex (ord c))
+
+      toHex ∷ Int → String
+      {-# INLINE toHex #-}
+      toHex n
+          = case showIntAtBase 16 toChrHex n "" of
+              []  → "00"
+              [c] → ['0', c]
+              cs  → cs
+
+      toChrHex ∷ Int → Char
+      {-# INLINE toChrHex #-}
+      toChrHex d
+          | d < 10    = chr (ord '0' + fromIntegral  d    )
+          | otherwise = chr (ord 'A' + fromIntegral (d-10))