Resurrection from bitrot

diff --git a/GNUmakefile b/GNUmakefile
index 0e02010d99239d25e10774392d9b541e1b7280a6..734bf84c80848bf9890e01608c1573c61fe95eef 100644 (file)
--- a/GNUmakefile
+++ b/GNUmakefile
@@ -1,6 +1,6 @@
 RUN_COMMAND = sudo ./dist/build/rakka/rakka -p 8989 -l DEBUG -v
 
 RUN_COMMAND = sudo ./dist/build/rakka/rakka -p 8989 -l DEBUG -v
 

-CONFIGURE_ARGS = --disable-optimization -fbuild-test-suite
+CONFIGURE_ARGS = -O2 -fbuild-test-suite

 
 include cabal-package.mk
 
 
 include cabal-package.mk
 

diff --git a/Main.hs b/Main.hs
index 430fdfc62d1281f5e23d6a78344ffde065c37df8..cf4cf8868008d7df0a11442ce23a974c95a76b1c 100644 (file)
--- a/Main.hs
+++ b/Main.hs
@@ -1,9 +1,12 @@
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE
+    CPP
+  , UnicodeSyntax
+  #-}

 import           Control.Exception
 import           Control.Monad
 import           Data.List
 import           Data.Maybe
 import           Control.Exception
 import           Control.Monad
 import           Data.List
 import           Data.Maybe

-import           Network
+import Network.Socket

 import           Network.HTTP.Lucu
 import           OpenSSL
 import           Rakka.Environment
 import           Network.HTTP.Lucu
 import           OpenSSL
 import           Rakka.Environment


@@ -40,7 +43,7 @@ logger = "Main"
 
 
 data CmdOpt
 
 
 data CmdOpt

-    = OptPortNum   PortNumber
+    = OptPortNum   ServiceName

     | OptLSDir     FilePath
     | OptUserName  String
     | OptGroupName String
     | OptLSDir     FilePath
     | OptUserName  String
     | OptGroupName String


@@ -51,8 +54,8 @@ data CmdOpt
     deriving (Eq, Show)
 
 
     deriving (Eq, Show)
 
 

-defaultPort :: PortNumber
-defaultPort = toEnum 8080
+defaultPort ∷ ServiceName
+defaultPort = "8080"

 
 defaultLocalStateDir :: FilePath
 defaultLocalStateDir = LOCALSTATEDIR -- replaced by CPP
 
 defaultLocalStateDir :: FilePath
 defaultLocalStateDir = LOCALSTATEDIR -- replaced by CPP


@@ -70,8 +73,8 @@ defaultLogLevel = NOTICE
 
 options :: [OptDescr CmdOpt]
 options = [ Option ['p'] ["port"]
 
 options :: [OptDescr CmdOpt]
 options = [ Option ['p'] ["port"]

-                   (ReqArg (OptPortNum . toEnum . read) "NUM")
-                   ("Port number to listen. (default: " ++ show defaultPort ++ ")")
+                   (ReqArg OptPortNum "NUM")
+                   ("Port number to listen. (default: " ++ defaultPort ++ ")")

 
           , Option ['d'] ["localstatedir"]
                    (ReqArg OptLSDir "DIR")
 
           , Option ['d'] ["localstatedir"]
                    (ReqArg OptLSDir "DIR")


@@ -143,7 +146,7 @@ main = withOpenSSL $
           withSystemLock (lsdir </> "lock") $
             withPidFile (lsdir </> "pid") $
               do setupLogger opts
           withSystemLock (lsdir </> "lock") $
             withPidFile (lsdir </> "pid") $
               do setupLogger opts

-                 env <- setupEnv lsdir portNum
+                 env ← setupEnv lsdir portNum

 
                  rebuildIndexIfRequested env opts
 
 
                  rebuildIndexIfRequested env opts
 


@@ -167,17 +170,15 @@ resTree env
                , (["users"       ], resUsers        env)
                 ]
 
                , (["users"       ], resUsers        env)
                 ]
 

-
-getPortNum :: [CmdOpt] -> IO PortNumber
+getPortNum ∷ [CmdOpt] → IO ServiceName

 getPortNum opts
 getPortNum opts

-    = do let xs = mapMaybe (\ x -> case x of
-                                     OptPortNum n -> Just n
-                                     _            -> Nothing) opts
+    = do let xs = mapMaybe (\x → case x of
+                                   OptPortNum n → Just n
+                                   _            → Nothing) opts

          case xs of
          case xs of

-           []     -> return defaultPort
-           (x:[]) -> return x
-           _      -> error "too many --port options."
-
+           []     → return defaultPort
+           (x:[]) → return x
+           _      → error "too many --port options."

 
 getUserID :: [CmdOpt] -> IO UserID
 getUserID opts
 
 getUserID :: [CmdOpt] -> IO UserID
 getUserID opts

diff --git a/Rakka.cabal b/Rakka.cabal
index 66117ced4b5f5f8d2c7889578dea4281cb42f094..6345b450638b255d7b7be49c7870d50727d388d5 100644 (file)
--- a/Rakka.cabal
+++ b/Rakka.cabal
@@ -61,12 +61,20 @@ Flag build-test-suite
 
 Executable rakka
     Build-Depends:
 
 Executable rakka
     Build-Depends:

-        FileManip, HTTP, HUnit, HsHyperEstraier, HsOpenSSL, HsSVN >=
+        base-unicode-symbols == 0.2.*,
+        case-insensitive     == 0.4.*,
+        filemanip            == 0.3.*,
+        text                 == 0.11.*,
+        hxt-relaxng          == 9.1.*,
+        time-http            == 0.1.*,
+        HTTP, HUnit, HsHyperEstraier, HsOpenSSL, HsSVN >=

         0.3.2, Lucu, base, bytestring, containers, dataenc, directory,
         utf8-string, filepath, hslogger, hxt, hxt-xpath, magic, mtl,
         network, parsec, stm, time, unix, zlib
         0.3.2, Lucu, base, bytestring, containers, dataenc, directory,
         utf8-string, filepath, hslogger, hxt, hxt-xpath, magic, mtl,
         network, parsec, stm, time, unix, zlib

+

     Main-Is:
         Main.hs
     Main-Is:
         Main.hs

+

     Other-Modules:
         Rakka.Attachment
         Rakka.Authorization
     Other-Modules:
         Rakka.Attachment
         Rakka.Authorization


@@ -104,9 +112,7 @@ Executable rakka
         Rakka.Wiki.Engine
         Rakka.Wiki.Formatter
         Rakka.Wiki.Parser
         Rakka.Wiki.Engine
         Rakka.Wiki.Formatter
         Rakka.Wiki.Parser

-    Extensions:
-        Arrows, ExistentialQuantification, ScopedTypeVariables,
-        DeriveDataTypeable, FlexibleInstances
+

     GHC-Options:
         -Wall -threaded
 
     GHC-Options:
         -Wall -threaded
 


@@ -121,7 +127,5 @@ Executable RakkaUnitTest
         ., tests
     Other-Modules:
         WikiParserTest
         ., tests
     Other-Modules:
         WikiParserTest

-    Extensions:
-        Arrows

     GHC-Options:
         -Wall -Werror
     GHC-Options:
         -Wall -Werror

diff --git a/Rakka/Attachment.hs b/Rakka/Attachment.hs
index 06a947610433ea9bf02770110a31a9c3daef7eff..eb7225d07e90dc520bc3e0b6080284352f763fc6 100644 (file)
--- a/Rakka/Attachment.hs
+++ b/Rakka/Attachment.hs
@@ -1,46 +1,47 @@
+{-# LANGUAGE
+    TypeOperators
+  , UnicodeSyntax
+  #-}

 module Rakka.Attachment
     ( Attachment(..)
     )
     where
 module Rakka.Attachment
     ( Attachment(..)
     )
     where

+import Control.Arrow
+import Control.Arrow.ArrowList
+import Control.Arrow.ListArrow
+import Control.Arrow.Unicode
+import System.IO.Unsafe
+import Text.XML.HXT.Arrow.ReadDocument
+import Text.XML.HXT.Arrow.WriteDocument
+import Text.XML.HXT.Arrow.XmlArrow
+import Text.XML.HXT.Arrow.XmlState
+import Text.XML.HXT.DOM.TypeDefs

 
 

-import           Control.Arrow
-import           Control.Arrow.ArrowList
-import           System.IO.Unsafe
-import           Text.XML.HXT.Arrow.ReadDocument
-import           Text.XML.HXT.Arrow.WriteDocument
-import           Text.XML.HXT.Arrow.XmlArrow
-import           Text.XML.HXT.Arrow.XmlIOStateArrow
-import           Text.XML.HXT.DOM.TypeDefs
-import           Text.XML.HXT.DOM.XmlKeywords
+class Attachment τ where
+    serializeToXmlTree     ∷ (ArrowChoice (⇝), ArrowXml (⇝)) ⇒ τ ⇝ XmlTree
+    deserializeFromXmlTree ∷ (ArrowChoice (⇝), ArrowXml (⇝)) ⇒ XmlTree ⇝ τ

 
 

-
-class Attachment t where
-    serializeToXmlTree     :: (ArrowChoice a, ArrowXml a) => a t XmlTree
-    deserializeFromXmlTree :: (ArrowChoice a, ArrowXml a) => a XmlTree t
-
-    serializeToString :: t -> String
+    -- FIXME: String? Am I okay with that?
+    serializeToString ∷ τ → String

     serializeToString attachment
     serializeToString attachment

-        = unsafePerformIO $
-          do [xmlStr] <- runX ( setErrorMsgHandler False fail
-                                >>>
-                                constA attachment
-                                >>>
+        = do [xmlStr] ← runLA ( constA attachment
+                                ⋙

                                 serializeToXmlTree
                                 serializeToXmlTree

-                                >>>
-                                writeDocumentToString [ (a_indent, v_1) ]
-                              )
+                                ⋙
+                                writeDocumentToString [ withIndent yes ]
+                              ) ()

              return xmlStr
 
              return xmlStr
 

-    deserializeFromString :: String -> t
+    deserializeFromString ∷ String → τ

     deserializeFromString source
         = unsafePerformIO $
     deserializeFromString source
         = unsafePerformIO $

-          do [ret] <- runX ( setErrorMsgHandler False fail
-                             >>>
-                             readString [ (a_validate         , v_0)
-                                        , (a_check_namespaces , v_1)
-                                        , (a_remove_whitespace, v_0)
-                                        ] source
-                             >>>
-                             deserializeFromXmlTree
-                           )
+          do [ret] ← runX ( setErrorMsgHandler False fail
+                            ⋙
+                            readString [ withValidate        no
+                                       , withCheckNamespaces yes
+                                       , withRemoveWS        yes
+                                       ] source
+                            ⋙
+                            deserializeFromXmlTree
+                          )

              return ret
              return ret

diff --git a/Rakka/Authorization.hs b/Rakka/Authorization.hs
index 97927c5e1252b855784df2c6528da73043d142cd..4ba4f12fb24c1f000bd8373d64213d678569d85f 100644 (file)
--- a/Rakka/Authorization.hs
+++ b/Rakka/Authorization.hs
@@ -1,3 +1,8 @@
+{-# LANGUAGE
+    OverloadedStrings
+  , UnicodeSyntax
+  #-}
+-- FIXME: authentication

 module Rakka.Authorization
     ( AuthDB
     , mkAuthDB
 module Rakka.Authorization
     ( AuthDB
     , mkAuthDB


@@ -7,31 +12,30 @@ module Rakka.Authorization
     , delUser
     )
     where
     , delUser
     )
     where

-
-import qualified Codec.Binary.UTF8.String as UTF8
+import Control.Applicative

 import           Control.Concurrent.STM
 import           Control.Concurrent.STM

-import           Control.Monad

 import           Control.Monad.Trans
 import           Control.Monad.Trans

-import qualified Data.ByteString as B
+import Data.ByteString (ByteString)

 import           Data.Map (Map)
 import qualified Data.Map as M hiding (Map)
 import           Data.Maybe
 import           Data.Map (Map)
 import qualified Data.Map as M hiding (Map)
 import           Data.Maybe

+import Data.Text (Text)
+import qualified Data.Text.Encoding as T
+import qualified Data.Text.IO as T

 import           OpenSSL.EVP.Base64
 import           OpenSSL.EVP.Digest
 import           OpenSSL.EVP.Base64
 import           OpenSSL.EVP.Digest

+import Prelude.Unicode

 import           Rakka.SystemConfig
 import           System.Directory
 import           System.FilePath
 
 import           Rakka.SystemConfig
 import           System.Directory
 import           System.FilePath
 

-

 data AuthDB
     = AuthDB {
 data AuthDB
     = AuthDB {

-        adbFilePath    :: !FilePath
-      , adbUserMap     :: !(TVar UserMap)
+        adbFilePath ∷ !FilePath
+      , adbUserMap  ∷ !(TVar UserMap)

       }
 
       }
 

-
-type UserMap = Map String String
-
+type UserMap = Map Text ByteString

 
 mkAuthDB :: FilePath -> IO AuthDB
 mkAuthDB lsdir
 
 mkAuthDB :: FilePath -> IO AuthDB
 mkAuthDB lsdir


@@ -43,72 +47,55 @@ mkAuthDB lsdir
                     }
 
 
                     }
 
 

-isValidPair :: MonadIO m => AuthDB -> String -> String -> m Bool
+isValidPair ∷ MonadIO m ⇒ AuthDB → Text → Text → m Bool

 isValidPair adb name pass
 isValidPair adb name pass

-    = liftIO $ do sha1 <- return . fromJust =<< getDigestByName "SHA1"
-                  let hash = digestBS sha1 $ B.pack $ UTF8.encode pass
-                  atomically $ do m <- readTVar (adbUserMap adb)
-                                  return (M.lookup name m == Just hash)
-
-
-getUserList :: MonadIO m => AuthDB -> m [String]
-getUserList adb
-    = liftIO $
-      atomically $
-      do m <- readTVar (adbUserMap adb)
-        return (M.keys m)
+    = liftIO $ do sha1 ← fromJust <$> getDigestByName "SHA1"
+                  let hash = digestBS' sha1 $ T.encodeUtf8 pass
+                  atomically $ do m ← readTVar (adbUserMap adb)
+                                  pure $ M.lookup name m ≡ Just hash

 
 

+getUserList ∷ MonadIO m ⇒ AuthDB → m [Text]
+getUserList = liftIO ∘ atomically ∘ (M.keys <$>) ∘ readTVar ∘ adbUserMap

 
 

-addUser :: MonadIO m => AuthDB -> String -> String -> m ()
+addUser ∷ MonadIO m ⇒ AuthDB → Text → Text → m ()

 addUser adb name pass
     = liftIO $
 addUser adb name pass
     = liftIO $

-      do sha1 <- return . fromJust =<< getDigestByName "SHA1"
-        let hash = digestBS sha1 $ B.pack $ UTF8.encode pass
-        m <- atomically $ do m <- readTVar (adbUserMap adb)
-                             let m' = M.insert name hash m
-                             writeTVar (adbUserMap adb) m'
-                             return m'
+      do sha1 ← fromJust <$> getDigestByName "SHA1"
+        let hash = digestBS' sha1 $ T.encodeUtf8 pass
+        m ← atomically $ do m ← readTVar (adbUserMap adb)
+                            let m' = M.insert name hash m
+                            writeTVar (adbUserMap adb) m'
+                            return m'

         saveUserMap (adbFilePath adb) m
 
         saveUserMap (adbFilePath adb) m
 

-
-delUser :: MonadIO m => AuthDB -> String -> m ()
+delUser ∷ MonadIO m ⇒ AuthDB → Text → m ()

 delUser adb name
     = liftIO $
 delUser adb name
     = liftIO $

-      do m <- atomically $ do m <- readTVar (adbUserMap adb)
-                             let m' = M.delete name m
-                             writeTVar (adbUserMap adb) m'
-                             return m'
+      do m ← atomically $ do m ← readTVar (adbUserMap adb)
+                            let m' = M.delete name m
+                            writeTVar (adbUserMap adb) m'
+                            return m'

         saveUserMap (adbFilePath adb) m
 
         saveUserMap (adbFilePath adb) m
 

-
-loadUserMap :: FilePath -> IO UserMap
+loadUserMap ∷ FilePath → IO UserMap

 loadUserMap path
 loadUserMap path

-    = do exist <- doesFileExist path
-         m     <- if exist then
-                      liftM (M.fromList . map decodePair . fromJust . deserializeStringPairs)
-                            (readFile path)
-                  else
-                      return M.empty
-         sha1  <- return . fromJust =<< getDigestByName "SHA1"
-         return (initMap sha1 m)
+    = do exist ← doesFileExist path
+         m     ← if exist then
+                     fromJust ∘ deserializeMap id (decodeBase64BS ∘ T.encodeUtf8)
+                     <$> T.readFile path
+                 else
+                     pure M.empty
+         sha1  ← fromJust <$> getDigestByName "SHA1"
+         pure $ initMap sha1 m

     where
     where

-      decodePair :: (String, String) -> (String, String)
-      decodePair (name, b64Hash)
-          = (UTF8.decodeString name, decodeBase64 b64Hash)
-
-      initMap :: Digest -> UserMap -> UserMap
+      initMap ∷ Digest → UserMap → UserMap

       initMap sha1 m
           | M.null m  = let name = "root"
       initMap sha1 m
           | M.null m  = let name = "root"

-                            hash = digest sha1 ""
+                            hash = digestBS' sha1 ""

                         in
                           M.singleton name hash
           | otherwise = m
 
                         in
                           M.singleton name hash
           | otherwise = m
 

-
-saveUserMap :: FilePath -> UserMap -> IO ()
-saveUserMap path m
-    = writeFile path $ serializeStringPairs $ map encodePair $ M.toList m
-    where
-    encodePair :: (String, String) -> (String, String)
-    encodePair (name, hash)
-       = (UTF8.encodeString name, encodeBase64 hash)
+saveUserMap ∷ FilePath → UserMap → IO ()
+saveUserMap path
+    = T.writeFile path ∘ serializeMap id (T.decodeUtf8 ∘ encodeBase64BS)

diff --git a/Rakka/Environment.hs b/Rakka/Environment.hs
index ea82209885001648f23c2853750c9451ba7364fe..c526c892dd771b1c179ad639e374361c9624b411 100644 (file)
--- a/Rakka/Environment.hs
+++ b/Rakka/Environment.hs
@@ -1,14 +1,16 @@
+{-# LANGUAGE
+    UnicodeSyntax
+  #-}

 module Rakka.Environment
     ( Environment(..)
     , InterpTable
     , setupEnv
     )
     where
 module Rakka.Environment
     ( Environment(..)
     , InterpTable
     , setupEnv
     )
     where

-
-import           Control.Arrow
-import           Control.Arrow.ArrowList
+import Control.Arrow.ArrowList
+import Control.Arrow.Unicode

 import qualified Data.Map as M
 import qualified Data.Map as M

-import           Network
+import Network.Socket

 import qualified Network.HTTP.Lucu.Config as LC
 import           Rakka.Authorization
 import           Rakka.Page
 import qualified Network.HTTP.Lucu.Config as LC
 import           Rakka.Authorization
 import           Rakka.Page


@@ -26,8 +28,7 @@ import           System.Directory
 import           System.FilePath
 import           System.Log.Logger
 import           Text.HyperEstraier
 import           System.FilePath
 import           System.Log.Logger
 import           Text.HyperEstraier

-import           Text.XML.HXT.Arrow.XmlIOStateArrow
-
+import Text.XML.HXT.Arrow.XmlState

 
 logger :: String
 logger = "Rakka.Environment"
 
 logger :: String
 logger = "Rakka.Environment"


@@ -43,15 +44,13 @@ data Environment = Environment {
     , envAuthDB        :: !AuthDB
     }
 
     , envAuthDB        :: !AuthDB
     }
 

-
-setupEnv :: FilePath -> PortNumber -> IO Environment
-setupEnv lsdir portNum
+setupEnv ∷ FilePath → ServiceName → IO Environment
+setupEnv lsdir port

     = do let lucuConf    = LC.defaultConfig {
     = do let lucuConf    = LC.defaultConfig {

-                             LC.cnfServerPort = PortNumber portNum
+                             LC.cnfServerPort = port

                            }
              reposPath   = lsdir </> "repos"
              interpTable = mkInterpTable
                            }
              reposPath   = lsdir </> "repos"
              interpTable = mkInterpTable

-         

          reposExist  <- doesDirectoryExist reposPath
          repos       <- if reposExist then
                             do debugM logger ("Found a subversion repository on " ++ reposPath)
          reposExist  <- doesDirectoryExist reposPath
          repos       <- if reposExist then
                             do debugM logger ("Found a subversion repository on " ++ reposPath)


@@ -62,7 +61,6 @@ setupEnv lsdir portNum
          sysConf     <- mkSystemConfig lucuConf repos
          storage     <- mkStorage lsdir repos (makeDraft' interpTable)
          authDB      <- mkAuthDB lsdir
          sysConf     <- mkSystemConfig lucuConf repos
          storage     <- mkStorage lsdir repos (makeDraft' interpTable)
          authDB      <- mkAuthDB lsdir

-

          return Environment {
                       envLocalStateDir = lsdir
                     , envLucuConf      = lucuConf
          return Environment {
                       envLocalStateDir = lsdir
                     , envLucuConf      = lucuConf


@@ -73,28 +71,27 @@ setupEnv lsdir portNum
                     , envAuthDB        = authDB
                     }
     where
                     , envAuthDB        = authDB
                     }
     where

-      makeDraft' :: InterpTable -> Page -> IO Document
+      makeDraft' ∷ InterpTable → Page → IO Document

       makeDraft' interpTable page
       makeDraft' interpTable page

-          = do [doc] <- runX ( setErrorMsgHandler False fail
-                               >>>
-                               constA page
-                               >>>
-                               xmlizePage
-                               >>>
-                               makeDraft interpTable
-                             )
+          = do [doc] ← runX ( setErrorMsgHandler False fail
+                              ⋙
+                              constA page
+                              ⋙
+                              xmlizePage
+                              ⋙
+                              makeDraft interpTable
+                            )

                return doc
 
                return doc
 

-
-mkInterpTable :: InterpTable
+mkInterpTable ∷ InterpTable

 mkInterpTable = listToTable $
 mkInterpTable = listToTable $

-                foldl (++) [] [ Base.interpreters
-                              , Image.interpreters
-                              , PageList.interpreters
-                              --, Trackback.interpreters
-                              , Outline.interpreters
-                              ]
+                concat [ Base.interpreters
+                       , Image.interpreters
+                       , PageList.interpreters
+                       --, Trackback.interpreters
+                       , Outline.interpreters
+                       ]

     where
     where

-      listToTable :: [Interpreter] -> InterpTable
+      listToTable ∷ [Interpreter] → InterpTable

       listToTable xs
       listToTable xs

-          = M.fromList [ (commandName x, x) | x <- xs ]
+          = M.fromList [ (commandName x, x) | x ← xs ]

diff --git a/Rakka/Page.hs b/Rakka/Page.hs
index ab2ae88f3b5dac6f34d22908638eb4de50ec7739..f845f7eee589b7d81a141ca653a7854a97213392 100644 (file)
--- a/Rakka/Page.hs
+++ b/Rakka/Page.hs
@@ -1,3 +1,8 @@
+{-# LANGUAGE
+    Arrows
+  , TypeOperators
+  , UnicodeSyntax
+  #-}

 module Rakka.Page
     ( PageName
     , Page(..)
 module Rakka.Page
     ( PageName
     , Page(..)


@@ -27,30 +32,40 @@ module Rakka.Page
     , parseXmlizedPage
     )
     where
     , parseXmlizedPage
     )
     where

-
+import Control.Applicative
+import Control.Arrow
+import Control.Arrow.ArrowIO
+import Control.Arrow.ArrowList
+import Control.Arrow.Unicode

 import qualified Codec.Binary.UTF8.String as UTF8
 import qualified Codec.Binary.UTF8.String as UTF8

+import qualified Data.ByteString.Char8 as B8

 import qualified Data.ByteString.Lazy as Lazy (ByteString)
 import qualified Data.ByteString.Lazy as L hiding (ByteString)
 import qualified Data.ByteString.Lazy.Char8 as L8 hiding (ByteString)
 import qualified Data.ByteString.Lazy as Lazy (ByteString)
 import qualified Data.ByteString.Lazy as L hiding (ByteString)
 import qualified Data.ByteString.Lazy.Char8 as L8 hiding (ByteString)

+import Data.CaseInsensitive (CI)
+import qualified Data.CaseInsensitive as CI

 import           Data.Char
 import           Data.Map (Map)
 import qualified Data.Map as M
 import           Data.Char
 import           Data.Map (Map)
 import qualified Data.Map as M

+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Text.Encoding

 import           Data.Time
 import           Network.HTTP.Lucu hiding (redirect)
 import           Network.URI hiding (fragment)
 import           OpenSSL.EVP.Base64
 import           Data.Time
 import           Network.HTTP.Lucu hiding (redirect)
 import           Network.URI hiding (fragment)
 import           OpenSSL.EVP.Base64

+import Prelude.Unicode

 import           Rakka.Utils
 import           Rakka.W3CDateTime
 import           Subversion.Types
 import           System.FilePath.Posix
 import           Rakka.Utils
 import           Rakka.W3CDateTime
 import           Subversion.Types
 import           System.FilePath.Posix

-import           Text.XML.HXT.Arrow
-import           Text.XML.HXT.XPath
-
-
-type PageName = String
+import Text.XML.HXT.Arrow.XmlArrow
+import Text.XML.HXT.DOM.TypeDefs
+import Text.XML.HXT.XPath

 
 

-type LanguageTag  = String -- See RFC 3066: http://www.ietf.org/rfc/rfc3066.txt
-type LanguageName = String -- i.e. "日本語"
+type PageName     = Text
+type LanguageTag  = CI Text -- See RFC 3066: http://www.ietf.org/rfc/rfc3066.txt
+type LanguageName = Text    -- i.e. "日本語"

 
 
 data Page
 
 
 data Page


@@ -120,37 +135,37 @@ pageRevision p
 
 
 -- UTF-8 に encode してから 0x20 - 0x7E の範圍を除いて URI escape する。
 
 
 -- UTF-8 に encode してから 0x20 - 0x7E の範圍を除いて URI escape する。

-encodePageName :: PageName -> FilePath
-encodePageName = escapeURIString isSafeChar . UTF8.encodeString . fixPageName
+encodePageName ∷ PageName → FilePath
+encodePageName = escapeURIString isSafeChar ∘ UTF8.encodeString ∘ fixPageName ∘ T.unpack

     where
     where

-      fixPageName :: PageName -> PageName
-      fixPageName = (\ (x:xs) -> toUpper x : xs) . map (\ c -> if c == ' ' then '_' else c)
+      fixPageName ∷ String → String
+      fixPageName = capitalizeHead ∘ map (\c → if c ≡ ' ' then '_' else c)

 
 

+      capitalizeHead ∷ String → String
+      capitalizeHead []     = (⊥)
+      capitalizeHead (x:xs) = toUpper x : xs

 
 

-decodePageName :: FilePath -> PageName
-decodePageName = UTF8.decodeString . unEscapeString
+-- FIXME: use system-filepath
+decodePageName ∷ FilePath → PageName
+decodePageName = T.pack ∘ UTF8.decodeString ∘ unEscapeString

 
 

+encodeFragment ∷ Text → String
+encodeFragment = escapeURIString isSafeChar ∘ B8.unpack ∘ encodeUtf8

 
 

-encodeFragment :: String -> String
-encodeFragment = escapeURIString isSafeChar . UTF8.encodeString
-
-
-mkPageURI :: URI -> PageName -> URI
+mkPageURI ∷ URI → PageName → URI

 mkPageURI baseURI name
     = baseURI {
         uriPath = uriPath baseURI </> encodePageName name <.> "html"
       }
 
 mkPageURI baseURI name
     = baseURI {
         uriPath = uriPath baseURI </> encodePageName name <.> "html"
       }
 

-
-mkPageFragmentURI :: URI -> PageName -> String -> URI
+mkPageFragmentURI ∷ URI → PageName → Text → URI

 mkPageFragmentURI baseURI name fragment
     = baseURI {
         uriPath     = uriPath baseURI </> encodePageName name <.> "html"
       , uriFragment = ('#' : encodeFragment fragment)
       }
 
 mkPageFragmentURI baseURI name fragment
     = baseURI {
         uriPath     = uriPath baseURI </> encodePageName name <.> "html"
       , uriFragment = ('#' : encodeFragment fragment)
       }
 

-
-mkFragmentURI :: String -> URI
+mkFragmentURI ∷ Text → URI

 mkFragmentURI fragment
     = nullURI {
         uriFragment = ('#' : encodeFragment fragment)
 mkFragmentURI fragment
     = nullURI {
         uriFragment = ('#' : encodeFragment fragment)


@@ -233,10 +248,10 @@ xmlizePage
           -> do lastMod <- arrIO (utcToLocalZonedTime . redirLastMod) -< page
                 ( eelem "/"
                   += ( eelem "page"
           -> do lastMod <- arrIO (utcToLocalZonedTime . redirLastMod) -< page
                 ( eelem "/"
                   += ( eelem "page"

-                       += sattr "name"     (redirName page)
-                       += sattr "redirect" (redirDest page)
-                       += sattr "isLocked" (yesOrNo $ redirIsLocked page)
-                       += sattr "revision" (show $ redirRevision page)
+                       += sattr "name"     (T.unpack $ redirName page    )
+                       += sattr "redirect" (T.unpack $ redirDest page    )
+                       += sattr "isLocked" (yesOrNo  $ redirIsLocked page)
+                       += sattr "revision" (show     $ redirRevision page)

                        += sattr "lastModified" (formatW3CDateTime lastMod)
                      )) -<< ()
 
                        += sattr "lastModified" (formatW3CDateTime lastMod)
                      )) -<< ()
 


@@ -246,10 +261,10 @@ xmlizePage
           -> do lastMod <- arrIO (utcToLocalZonedTime . entityLastMod) -< page
                 ( eelem "/"
                   += ( eelem "page"
           -> do lastMod <- arrIO (utcToLocalZonedTime . entityLastMod) -< page
                 ( eelem "/"
                   += ( eelem "page"

-                       += sattr "name" (pageName page)
+                       += sattr "name" (T.unpack $ pageName page)

                        += sattr "type" (show $ entityType page)
                        += ( case entityLanguage page of
                        += sattr "type" (show $ entityType page)
                        += ( case entityLanguage page of

-                              Just x  -> sattr "lang" x
+                              Just x  -> sattr "lang" (T.unpack $ CI.foldedCase x)

                               Nothing -> none
                           )
                        += ( case entityType page of
                               Nothing -> none
                           )
                        += ( case entityType page of


@@ -273,9 +288,9 @@ xmlizePage
                             else
                                 selem "otherLang"
                                           [ eelem "link"
                             else
                                 selem "otherLang"
                                           [ eelem "link"

-                                            += sattr "lang" lang
-                                            += sattr "page" name
-                                                | (lang, name) <- M.toList (entityOtherLang page) ]
+                                            += sattr "lang" (T.unpack $ CI.foldedCase lang)
+                                            += sattr "page" (T.unpack name)
+                                                | (lang, name) ← M.toList (entityOtherLang page) ]

                           )
                        += ( if entityIsBinary page then
                                 ( eelem "binaryData"
                           )
                        += ( if entityIsBinary page then
                                 ( eelem "binaryData"


@@ -288,25 +303,23 @@ xmlizePage
                           )
                      )) -<< ()
 
                           )
                      )) -<< ()
 

-
-parseXmlizedPage :: (ArrowXml a, ArrowChoice a) => a (PageName, XmlTree) Page
+parseXmlizedPage ∷ (ArrowXml (⇝), ArrowChoice (⇝)) ⇒ (PageName, XmlTree) ⇝ Page

 parseXmlizedPage 
     = proc (name, tree)
 parseXmlizedPage 
     = proc (name, tree)

-    -> do updateInfo <- maybeA parseUpdateInfo -< tree
-          redirect   <- maybeA (getXPathTreesInDoc "/page/@redirect/text()" >>> getText) -< tree
-          isLocked   <- (withDefault (getXPathTreesInDoc "/page/@isLocked/text()" >>> getText) "no"
-                         >>> parseYesOrNo) -< tree
-          case redirect of
-            Nothing   -> parseEntity -< (name, tree)
-            Just dest -> returnA     -< (Redirection {
-                                           redirName       = name
-                                         , redirDest       = dest
-                                         , redirIsLocked   = isLocked
-                                         , redirRevision   = undefined
-                                         , redirLastMod    = undefined
-                                         , redirUpdateInfo = updateInfo
-                                         })
-            
+    → do updateInfo ← maybeA parseUpdateInfo ⤙ tree
+         redirect   ← maybeA (getXPathTreesInDoc "/page/@redirect/text()" ⋙ getText) ⤙ tree
+         isLocked   ← (withDefault (getXPathTreesInDoc "/page/@isLocked/text()" ⋙ getText) "no"
+                       ⋙ parseYesOrNo) ⤙ tree
+         case redirect of
+           Nothing   → parseEntity ⤙ (name, tree)
+           Just dest → returnA     ⤙ Redirection {
+                                        redirName       = name
+                                      , redirDest       = T.pack dest
+                                      , redirIsLocked   = isLocked
+                                      , redirRevision   = undefined
+                                      , redirLastMod    = undefined
+                                      , redirUpdateInfo = updateInfo
+                                      }

 
 parseEntity :: (ArrowXml a, ArrowChoice a) => a (PageName, XmlTree) Page
 parseEntity
 
 parseEntity :: (ArrowXml a, ArrowChoice a) => a (PageName, XmlTree) Page
 parseEntity


@@ -343,18 +356,17 @@ parseEntity
                       (Nothing  , Just binary) -> (True , L8.pack $ decodeBase64 $ dropWhitespace binary)
                       _                        -> error "one of textData or binaryData is required"
               mimeType
                       (Nothing  , Just binary) -> (True , L8.pack $ decodeBase64 $ dropWhitespace binary)
                       _                        -> error "one of textData or binaryData is required"
               mimeType

-                  =  if isBinary then
-                         if null mimeTypeStr then
-                             guessMIMEType content
-                         else
-                             read mimeTypeStr
-                     else
-                         read mimeTypeStr
-
-          returnA -< Entity {
+                  = if isBinary then
+                        if null mimeTypeStr then
+                            guessMIMEType content
+                        else
+                            read mimeTypeStr
+                    else
+                        read mimeTypeStr
+          returnA ⤙ Entity {

                         entityName       = name
                       , entityType       = mimeType
                         entityName       = name
                       , entityType       = mimeType

-                      , entityLanguage   = lang
+                      , entityLanguage   = CI.mk ∘ T.pack <$> lang

                       , entityIsTheme    = isTheme
                       , entityIsFeed     = isFeed
                       , entityIsLocked   = isLocked
                       , entityIsTheme    = isTheme
                       , entityIsFeed     = isFeed
                       , entityIsLocked   = isLocked


@@ -362,7 +374,7 @@ parseEntity
                       , entityRevision   = undefined
                       , entityLastMod    = undefined
                       , entitySummary    = summary
                       , entityRevision   = undefined
                       , entityLastMod    = undefined
                       , entitySummary    = summary

-                      , entityOtherLang  = M.fromList otherLang
+                      , entityOtherLang  = M.fromList ((CI.mk ∘ T.pack ⁂ T.pack) <$> otherLang)

                       , entityContent    = content
                       , entityUpdateInfo = updateInfo
                       }
                       , entityContent    = content
                       , entityUpdateInfo = updateInfo
                       }


@@ -375,16 +387,13 @@ parseEntity
           | otherwise
               = x : dropWhitespace xs
 
           | otherwise
               = x : dropWhitespace xs
 

-
-parseUpdateInfo :: (ArrowXml a, ArrowChoice a) => a XmlTree UpdateInfo
+parseUpdateInfo ∷ (ArrowXml (⇝), ArrowChoice (⇝)) ⇒ XmlTree ⇝ UpdateInfo

 parseUpdateInfo 
     = proc tree
 parseUpdateInfo 
     = proc tree

-    -> do uInfo   <- getXPathTreesInDoc "/page/updateInfo" -< tree
-          oldRev  <- (getAttrValue0 "oldRevision" >>> arr read) -< uInfo
-          oldName <- maybeA (getXPathTrees "/updateInfo/move/@from/text()" >>> getText) -< uInfo
-          returnA -< UpdateInfo {
-                        uiOldRevision = oldRev
-                      , uiOldName     = oldName
-                      }
-
-      
+    -> do uInfo   ← getXPathTreesInDoc "/page/updateInfo" ⤙ tree
+          oldRev  ← (getAttrValue0 "oldRevision" ⋙ arr read) ⤙ uInfo
+          oldName ← maybeA (getXPathTrees "/updateInfo/move/@from/text()" ⋙ getText) ⤙ uInfo
+          returnA ⤙ UpdateInfo {
+                       uiOldRevision = oldRev
+                     , uiOldName     = T.pack <$> oldName
+                     }

diff --git a/Rakka/Resource.hs b/Rakka/Resource.hs
index c589cecceb1cea38f9ada43cc13b73b6eb7d4ebd..a6fc01f492f1b4fcf27089f80c6e335cadeaee90 100644 (file)
--- a/Rakka/Resource.hs
+++ b/Rakka/Resource.hs
@@ -1,3 +1,8 @@
+{-# LANGUAGE
+    Arrows
+  , DoAndIfThenElse
+  , UnicodeSyntax
+  #-}

 module Rakka.Resource
     ( runIdempotentA
     , runIdempotentA'
 module Rakka.Resource
     ( runIdempotentA
     , runIdempotentA'


@@ -9,26 +14,28 @@ module Rakka.Resource
     , getUserID
     )
     where
     , getUserID
     )
     where

-

 import qualified Codec.Binary.UTF8.String as UTF8
 import qualified Codec.Binary.UTF8.String as UTF8

-import           Control.Arrow
-import           Control.Arrow.ArrowList
+import Control.Arrow
+import Control.Arrow.ArrowList
+import Control.Arrow.ListArrow
+import Control.Arrow.Unicode

 import           Control.Monad
 import           Control.Monad.Trans
 import           Control.Monad
 import           Control.Monad.Trans

+import Data.Monoid.Unicode
+import qualified Data.Text as T

 import           Network.HTTP.Lucu
 import           Network.HTTP.Lucu.Utils
 import           Network.URI hiding (path)
 import           Network.HTTP.Lucu
 import           Network.HTTP.Lucu.Utils
 import           Network.URI hiding (path)

+import Prelude.Unicode

 import           Rakka.Authorization
 import           Rakka.Environment
 import           Rakka.Validation
 import           System.FilePath.Posix
 import           System.Log.Logger
 import           Rakka.Authorization
 import           Rakka.Environment
 import           Rakka.Validation
 import           System.FilePath.Posix
 import           System.Log.Logger

-import           Text.XML.HXT.Arrow.ReadDocument
-import           Text.XML.HXT.Arrow.WriteDocument
-import           Text.XML.HXT.Arrow.XmlIOStateArrow
-import           Text.XML.HXT.DOM.TypeDefs
-import           Text.XML.HXT.DOM.XmlKeywords
-
+import Text.XML.HXT.Arrow.ReadDocument
+import Text.XML.HXT.Arrow.WriteDocument
+import Text.XML.HXT.DOM.TypeDefs
+import Text.XML.HXT.Arrow.XmlState

 
 logger :: String
 logger = "Rakka.Resource"
 
 logger :: String
 logger = "Rakka.Resource"


@@ -80,55 +87,53 @@ runIdempotentA' a
                                  )
          rsrc
 
                                  )
          rsrc
 

-
-runXmlA :: Environment -> FilePath -> IOSArrow XmlTree (Resource c) -> Resource c
-runXmlA env schemaPath a
-    = do inputA <- getInputXmlA env schemaPath
-         [rsrc] <- liftIO $ runX ( inputA
-                                   >>>
+runXmlA ∷ FilePath → IOSArrow XmlTree (Resource c) → Resource c
+runXmlA schemaPath a
+    = do inputA ← getInputXmlA schemaPath
+         [rsrc] ← liftIO $ runX ( inputA
+                                   ⋙

                                    setErrorMsgHandler False fail
                                    setErrorMsgHandler False fail

-                                   >>>
+                                   ⋙

                                    a
                                  )
          rsrc
 
                                    a
                                  )
          rsrc
 

-

 -- well-formed でない時は 400 Bad Request になり、valid でない時は 422
 -- Unprocessable Entity になる。入力の型が XML でない時は 415
 -- Unsupported Media Type を返す。
 -- well-formed でない時は 400 Bad Request になり、valid でない時は 422
 -- Unprocessable Entity になる。入力の型が XML でない時は 415
 -- Unsupported Media Type を返す。

-getInputXmlA :: Environment -> FilePath -> Resource (IOSArrow b XmlTree)
-getInputXmlA env schemaPath
-    = do reader    <- getInputReader
-         validator <- getValidator env schemaPath
-         return ( setErrorMsgHandler False (abort BadRequest [] . Just)
-                  >>>
+getInputXmlA ∷ FilePath → Resource (IOSArrow b XmlTree)
+getInputXmlA schemaPath
+    = do reader    ← getInputReader
+         validator ← getValidator schemaPath
+         return ( setErrorMsgHandler False (abort BadRequest [] ∘ Just)
+                  ⋙

                   reader
                   reader

-                  >>>
-                  setErrorMsgHandler False (abort UnprocessableEntitiy [] . Just)
-                  >>>
+                  ⋙
+                  setErrorMsgHandler False (abort UnprocessableEntitiy [] ∘ Just)
+                  ⋙

                   validator
                 )
 
                   validator
                 )
 

-
-getInputReader :: Resource (IOSArrow b XmlTree)
+getInputReader ∷ Resource (IOSArrow b XmlTree)

 getInputReader 
 getInputReader 

-    = do mimeType <- getContentType
+    = do mimeType ← getContentType

          case mimeType of
            Nothing
          case mimeType of
            Nothing

-               -> getFailingReader BadRequest [] (Just "Missing Content-Type")
+               → getFailingReader BadRequest [] (Just "Missing Content-Type")

            Just (MIMEType "text" "xml" _)
            Just (MIMEType "text" "xml" _)

-               -> getXmlReader
+               → getXmlReader

            Just (MIMEType "application" "xml" _)
            Just (MIMEType "application" "xml" _)

-               -> getXmlReader
+               → getXmlReader

            Just t
            Just t

-               -> getFailingReader UnsupportedMediaType [] (Just $ "Unsupported media type: " ++ show t)
+               → getFailingReader UnsupportedMediaType []
+                      (Just $ "Unsupported media type: " ⊕ show t)

     where
       getXmlReader
     where
       getXmlReader

-          = do req <- input defaultLimit
+          = do req ← input defaultLimit

                liftIO $ debugM logger req
                liftIO $ debugM logger req

-               return $ readString [ (a_validate         , v_0)
-                                   , (a_check_namespaces , v_1)
-                                   , (a_remove_whitespace, v_0)
+               return $ readString [ withValidate        no
+                                   , withCheckNamespaces yes
+                                   , withRemoveWS        yes

                                    ] (UTF8.decodeString req)
       getFailingReader code headers msg
           = return $ proc _ -> abortA -< (code, (headers, msg))
                                    ] (UTF8.decodeString req)
       getFailingReader code headers msg
           = return $ proc _ -> abortA -< (code, (headers, msg))


@@ -149,53 +154,51 @@ getEntityType
                ]
 
 
                ]
 
 

-outputXmlPage :: XmlTree -> [(MIMEType, IOSArrow XmlTree XmlTree)] -> Resource ()
+outputXmlPage ∷ XmlTree → [(MIMEType, IOSArrow XmlTree XmlTree)] → Resource ()

 outputXmlPage tree formatters
 outputXmlPage tree formatters

-    = do mType <- getEntityType
+    = do mType ← getEntityType

          setContentType mType
          let formatter = case lookup mType formatters of
          setContentType mType
          let formatter = case lookup mType formatters of

-                           Just f  -> f
-                           Nothing -> this
-         [resultStr] <- liftIO $ runX ( setErrorMsgHandler False fail
-                                        >>>
-                                        constA tree
-                                        >>>
-                                        formatter
-                                        >>>
-                                        writeDocumentToString [ (a_indent         , v_1 )
-                                                              , (a_output_encoding, utf8)
-                                                              , (a_no_xml_pi      , v_0 ) ]
-                                      )
-         output resultStr
-
+                           Just f  → f
+                           Nothing → this
+         [resultStr] ← liftIO $
+                       runX ( setErrorMsgHandler False fail
+                              >>>
+                              constA tree
+                              >>>
+                              formatter
+                              >>>
+                              writeDocumentToString
+                              [ withIndent yes
+                              , withXmlPi  yes
+                              ]
+                            )
+         output $ UTF8.encodeString resultStr

 
 outputXmlPage' :: XmlTree -> IOSArrow XmlTree XmlTree -> Resource ()
 outputXmlPage' tree toXHTML
     = outputXmlPage tree [(MIMEType "application" "xhtml+xml" [], toXHTML)]
 
 
 outputXmlPage' :: XmlTree -> IOSArrow XmlTree XmlTree -> Resource ()
 outputXmlPage' tree toXHTML
     = outputXmlPage tree [(MIMEType "application" "xhtml+xml" [], toXHTML)]
 

-
-outputXml :: XmlTree -> Resource ()
+outputXml ∷ XmlTree → Resource ()

 outputXml tree
     = do setContentType (MIMEType "text" "xml" [])
 outputXml tree
     = do setContentType (MIMEType "text" "xml" [])

-         [xmlStr] <- liftIO $ runX ( setErrorMsgHandler False fail
-                                    >>>
-                                    constA tree
-                                    >>>
-                                    writeDocumentToString [ (a_indent         , v_1 )
-                                                           , (a_output_encoding, utf8)
-                                                           , (a_no_xml_pi      , v_0 ) ]
-                                  )
-        output xmlStr
-
-
-getUserID :: Environment -> Resource (Maybe String)
+         let [xmlStr] = runLA ( writeDocumentToString
+                                [ withIndent yes
+                                , withXmlPi  yes
+                                ]
+                              ) tree
+         output $ UTF8.encodeString xmlStr
+
+getUserID ∷ Environment → Resource (Maybe String)

 getUserID env
 getUserID env

-    = do auth <- getAuthorization
+    = do auth ← getAuthorization

          case auth of
            Just (BasicAuthCredential userID password)
          case auth of
            Just (BasicAuthCredential userID password)

-               -> do valid <- isValidPair (envAuthDB env) userID password
-                     if valid then
-                         return (Just userID)
-                       else
-                         return Nothing
-           _   -> return Nothing
+               → do valid ← isValidPair (envAuthDB env)
+                                        (T.pack userID)
+                                        (T.pack password)
+                    if valid then
+                        return (Just userID)
+                    else
+                        return Nothing
+           _   → return Nothing

diff --git a/Rakka/Resource/Index.hs b/Rakka/Resource/Index.hs
index db8552dd2774e3fc6b042fb39555b112ed2291ce..31893e063f12acbdfe3022c537e8cd257943357c 100644 (file)
--- a/Rakka/Resource/Index.hs
+++ b/Rakka/Resource/Index.hs
@@ -1,22 +1,23 @@
+{-# LANGUAGE
+    UnicodeSyntax
+  #-}

 module Rakka.Resource.Index
     ( resIndex
     )
     where
 module Rakka.Resource.Index
     ( resIndex
     )
     where

+import Network.HTTP.Lucu
+import Rakka.Environment
+import Rakka.Page
+import Rakka.SystemConfig

 
 

-import           Network.HTTP.Lucu
-import           Rakka.Environment
-import           Rakka.Page
-import           Rakka.SystemConfig
-
-
-resIndex :: Environment -> ResourceDef
+resIndex ∷ Environment → ResourceDef

 resIndex env
     = ResourceDef {
         resUsesNativeThread = False
       , resIsGreedy         = False
       , resGet
 resIndex env
     = ResourceDef {
         resUsesNativeThread = False
       , resIsGreedy         = False
       , resGet

-          = Just $ do BaseURI baseURI  <- getSysConf (envSysConf env)
-                      DefaultPage name <- getSysConf (envSysConf env)
+          = Just $ do BaseURI baseURI  ← getSysConf (envSysConf env)
+                      DefaultPage name ← getSysConf (envSysConf env)

                       redirect Found (mkPageURI baseURI name)
       , resHead             = Nothing
       , resPost             = Nothing
                       redirect Found (mkPageURI baseURI name)
       , resHead             = Nothing
       , resPost             = Nothing

diff --git a/Rakka/Resource/Object.hs b/Rakka/Resource/Object.hs
index d4db7db60e8c894ac77e4bf142411c7e76fa3996..3a98b1e262810fdb403ac69c81fb7bb2fda9a7a6 100644 (file)
--- a/Rakka/Resource/Object.hs
+++ b/Rakka/Resource/Object.hs
@@ -1,33 +1,35 @@
--- -*- Coding: utf-8 -*-
+{-# LANGUAGE
+    UnicodeSyntax
+  #-}

 module Rakka.Resource.Object
     ( resObject
     )
     where
 module Rakka.Resource.Object
     ( resObject
     )
     where

-

 import qualified Codec.Binary.UTF8.String as UTF8
 import qualified Codec.Binary.UTF8.String as UTF8

+import Control.Monad.Unicode
+import qualified Data.Text as T

 import           Network.HTTP.Lucu
 import           Network.HTTP.Lucu

+import Prelude.Unicode

 import           Rakka.Environment
 import           Rakka.Page
 import           Rakka.Storage
 import           Rakka.SystemConfig
 import           System.FilePath.Posix
 
 import           Rakka.Environment
 import           Rakka.Page
 import           Rakka.Storage
 import           Rakka.SystemConfig
 import           System.FilePath.Posix
 

-
-resObject :: Environment -> ResourceDef
+resObject ∷ Environment → ResourceDef

 resObject env
     = ResourceDef {
         resUsesNativeThread = False
       , resIsGreedy         = True
 resObject env
     = ResourceDef {
         resUsesNativeThread = False
       , resIsGreedy         = True

-      , resGet              = Just $ getPathInfo >>= handleGet env . toPageName
+      , resGet              = Just $ getPathInfo ≫= handleGet env ∘ toPageName

       , resHead             = Nothing
       , resPost             = Nothing
       , resPut              = Nothing
       , resDelete           = Nothing
       }
     where
       , resHead             = Nothing
       , resPost             = Nothing
       , resPut              = Nothing
       , resDelete           = Nothing
       }
     where

-      toPageName :: [String] -> PageName
-      toPageName = UTF8.decodeString . joinPath
-
+      toPageName ∷ [String] → PageName
+      toPageName = T.pack ∘ UTF8.decodeString . joinPath

 
 handleGet :: Environment -> PageName -> Resource ()
 handleGet env name
 
 handleGet :: Environment -> PageName -> Resource ()
 handleGet env name

diff --git a/Rakka/Resource/PageEntity.hs b/Rakka/Resource/PageEntity.hs
index a1d4b02e85da6c2430dad72d61c60d7a7d7d2097..1388f71cc78024f144b7ad44f9a6dcdfc7b6f250 100644 (file)
--- a/Rakka/Resource/PageEntity.hs
+++ b/Rakka/Resource/PageEntity.hs
@@ -1,17 +1,32 @@
+{-# LANGUAGE
+    Arrows
+  , OverloadedStrings
+  , TypeOperators
+  , UnicodeSyntax
+  #-}

 module Rakka.Resource.PageEntity
     ( fallbackPageEntity
     )
     where
 module Rakka.Resource.PageEntity
     ( fallbackPageEntity
     )
     where

-
+import Control.Applicative
+import Control.Arrow
+import Control.Arrow.ArrowIO
+import Control.Arrow.ArrowIf
+import Control.Arrow.ArrowList
+import Control.Arrow.Unicode

 import qualified Codec.Binary.UTF8.String as UTF8
 import           Control.Monad.Trans
 import qualified Data.ByteString.Lazy as L hiding (ByteString)
 import qualified Codec.Binary.UTF8.String as UTF8
 import           Control.Monad.Trans
 import qualified Data.ByteString.Lazy as L hiding (ByteString)

+import qualified Data.CaseInsensitive as CI

 import           Data.Char
 import qualified Data.Map as M
 import           Data.Maybe
 import           Data.Char
 import qualified Data.Map as M
 import           Data.Maybe

+import Data.Monoid.Unicode
+import qualified Data.Text as T

 import           Data.Time
 import           Network.HTTP.Lucu
 import           Network.URI hiding (path)
 import           Data.Time
 import           Network.HTTP.Lucu
 import           Network.URI hiding (path)

+import Prelude.Unicode

 import           Rakka.Environment
 import           Rakka.Page
 import           Rakka.Resource
 import           Rakka.Environment
 import           Rakka.Page
 import           Rakka.Resource


@@ -22,16 +37,19 @@ import           Rakka.W3CDateTime
 import           Rakka.Wiki.Engine
 import           System.FilePath.Posix
 import           Text.HyperEstraier hiding (getText)
 import           Rakka.Wiki.Engine
 import           System.FilePath.Posix
 import           Text.HyperEstraier hiding (getText)

-import           Text.XML.HXT.Arrow
-import           Text.XML.HXT.XPath
-
-
-fallbackPageEntity :: Environment -> [String] -> IO (Maybe ResourceDef)
+import Text.XML.HXT.Arrow.Namespace
+import Text.XML.HXT.Arrow.WriteDocument
+import Text.XML.HXT.Arrow.XmlArrow
+import Text.XML.HXT.Arrow.XmlState
+import Text.XML.HXT.DOM.TypeDefs
+import Text.XML.HXT.XPath
+
+fallbackPageEntity ∷ Environment → [String] → IO (Maybe ResourceDef)

 fallbackPageEntity env path
 fallbackPageEntity env path

-    | null name           = return Nothing
-    | isLower $ head name = return Nothing -- 先頭の文字が小文字であってはならない
+    | T.null name           = return Nothing
+    | isLower $ T.head name = return Nothing -- 先頭の文字が小文字であってはならない

     | otherwise
     | otherwise

-        = return $ Just $ ResourceDef {
+        = pure $ Just ResourceDef {

             resUsesNativeThread = False
           , resIsGreedy         = True
           , resGet              = Just $ handleGet    env name
             resUsesNativeThread = False
           , resIsGreedy         = True
           , resGet              = Just $ handleGet    env name


@@ -41,9 +59,8 @@ fallbackPageEntity env path
           , resDelete           = Just $ handleDelete env name
           }
     where
           , resDelete           = Just $ handleDelete env name
           }
     where

-      name :: PageName
-      name = (dropExtension . UTF8.decodeString . joinPath) path
-
+      name ∷ PageName
+      name = T.pack ∘ dropExtension ∘ UTF8.decodeString $ joinPath path

 
 handleGet :: Environment -> PageName -> Resource ()
 handleGet env name
 
 handleGet :: Environment -> PageName -> Resource ()
 handleGet env name


@@ -62,37 +79,36 @@ handleGet env name
                             else
                                 handleRedirect env -< page
 
                             else
                                 handleRedirect env -< page
 

-

 {-
   HTTP/1.1 302 Found
   Location: http://example.org/Destination.html#Redirect:Source
 -}
 {-
   HTTP/1.1 302 Found
   Location: http://example.org/Destination.html#Redirect:Source
 -}

-handleRedirect :: (ArrowXml a, ArrowIO a) => Environment -> a Page (Resource ())
+handleRedirect ∷ (ArrowXml (⇝), ArrowIO (⇝)) ⇒ Environment → Page ⇝ Resource ()

 handleRedirect env
     = proc redir
 handleRedirect env
     = proc redir

-    -> returnA -< do mType <- getEntityType
-                     case mType of
-                       MIMEType "text" "xml" _
-                           -> do setContentType mType
-                                 [resultStr] <- liftIO $ runX ( setErrorMsgHandler False fail
-                                                                >>>
-                                                                constA redir
-                                                                >>>
-                                                                xmlizePage
-                                                                >>>
-                                                                writeDocumentToString [ (a_indent         , v_1 )
-                                                                                      , (a_output_encoding, utf8)
-                                                                                      , (a_no_xml_pi      , v_0 ) ]
-                                                              )
-                                 output resultStr
-
-                       _   -> do BaseURI baseURI <- getSysConf (envSysConf env)
-                                 let uri = mkPageFragmentURI
-                                           baseURI
-                                           (redirDest redir)
-                                           ("Redirect:" ++ redirName redir)
-                                 redirect Found uri
-
+    → returnA ⤙ do mType ← getEntityType
+                   case mType of
+                     MIMEType "text" "xml" _
+                         → do setContentType mType
+                              [resultStr] ← liftIO $
+                                            runX ( setErrorMsgHandler False fail
+                                                   ⋙
+                                                   constA redir
+                                                   ⋙
+                                                   xmlizePage
+                                                   ⋙
+                                                   writeDocumentToString
+                                                   [ withIndent yes
+                                                   , withXmlPi  yes
+                                                   ]
+                                                 )
+                              output $ UTF8.encodeString resultStr
+                     _   → do BaseURI baseURI ← getSysConf (envSysConf env)
+                              let uri = mkPageFragmentURI
+                                        baseURI
+                                        (redirDest redir)
+                                        ("Redirect:" ⊕ redirName redir)
+                              redirect Found uri

 
 handleGetEntity :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a Page (Resource ())
 handleGetEntity env
 
 handleGetEntity :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a Page (Resource ())
 handleGetEntity env


@@ -103,222 +119,220 @@ handleGetEntity env
                                         ]
 
 
                                         ]
 
 

-entityToXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a XmlTree XmlTree
+entityToXHTML ∷ (ArrowXml (⇝), ArrowChoice (⇝), ArrowIO (⇝))
+              ⇒ Environment
+              → XmlTree ⇝ XmlTree

 entityToXHTML env
     = proc page
 entityToXHTML env
     = proc page

-    -> do SiteName   siteName   <- getSysConfA (envSysConf env) -< ()
-          BaseURI    baseURI    <- getSysConfA (envSysConf env) -< ()
-          StyleSheet styleSheet <- getSysConfA (envSysConf env) -< ()
-          GlobalLock isGLocked  <- getSysConfA (envSysConf env) -< ()
-
-          name     <- (getXPathTreesInDoc "/page/@name/text()" >>> getText) -< page
-          isLocked <- (getXPathTreesInDoc "/page/@isLocked/text()" >>> getText >>> parseYesOrNo) -< page
-
-          let cssHref   = [uriToString id (mkObjectURI baseURI styleSheet) ""]
-              scriptSrc = [uriToString id (baseURI { uriPath = uriPath baseURI </> "js" }) ""]
-
-          pageTitle    <- listA (readSubPage env) -< (name, Just page, "PageTitle")
-          leftSideBar  <- listA (readSubPage env) -< (name, Just page, "SideBar/Left")
-          rightSideBar <- listA (readSubPage env) -< (name, Just page, "SideBar/Right")
-          pageBody     <- listA (makeMainXHTML (envStorage env) (envSysConf env) (envInterpTable env)) -< page
-
-          ( eelem "/"
-            += ( eelem "html"
-                 += sattr "xmlns" "http://www.w3.org/1999/xhtml"
-                 += ( getXPathTreesInDoc "/page/@lang"
-                      `guards`
-                      qattr (mkQName "xml" "lang" "")
-                                ( getXPathTreesInDoc "/page/@lang/text()" )
-                    )
-                 += ( eelem "head"
-                      += ( eelem "title"
-                           += txt siteName
-                           += txt " - "
-                           += getXPathTreesInDoc "/page/@name/text()"
-                         )
-                      += ( constL cssHref
-                           >>>
-                           eelem "link"
-                           += sattr "rel"  "stylesheet"
-                           += sattr "type" "text/css"
-                           += attr "href" (arr id >>> mkText)
-                         )
-                      += mkFeedList env
-                      += ( constL scriptSrc
-                           >>>
-                           eelem "script"
-                           += sattr "type" "text/javascript"
-                           += attr "src" (arr id >>> mkText)
-                         )
-                      += ( eelem "script"
-                           += sattr "type" "text/javascript"
-                           += txt ("Rakka.baseURI=\"" ++ uriToString id baseURI "" ++ "\";")
-                           += txt ("Rakka.isLocked=" ++ trueOrFalse isLocked ++ ";")
-                           += txt ("Rakka.isGlobalLocked=" ++ trueOrFalse isGLocked ++ ";")
-                         )
-                      += mkGlobalJSList env
-                    )
-                 += ( eelem "body"
-                      += ( eelem "div"
-                           += sattr "class" "header"
-                         )
-                      += ( eelem "div"
-                           += sattr "class" "center"
-                           += ( eelem "div"
-                                += sattr "class" "title"
-                                += constL pageTitle
-                              )
-                           += ( eelem "div"
-                                += sattr "class" "body"
-                                += constL pageBody
-                              )
-                         )
-                      += ( eelem "div"
-                           += sattr "class" "footer"
-                         )
-                      += ( eelem "div"
-                           += sattr "class" "left sideBar"
-                           += ( eelem "div"
-                                += sattr "class" "content"
-                                += constL leftSideBar
-                              )
-                         )
-                      += ( eelem "div"
-                           += sattr "class" "right sideBar"
-                           += ( eelem "div"
-                                += sattr "class" "content"
-                                += constL rightSideBar
-                              )
-                         )
-                    )
-                 >>>
-                 uniqueNamespacesFromDeclAndQNames
-               ) ) -<< page
-
-
-entityToRSS :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a XmlTree XmlTree
+    → do SiteName   siteName   ← getSysConfA (envSysConf env) ⤙ ()
+         BaseURI    baseURI    ← getSysConfA (envSysConf env) ⤙ ()
+         StyleSheet styleSheet ← getSysConfA (envSysConf env) ⤙ ()
+         GlobalLock isGLocked  ← getSysConfA (envSysConf env) ⤙ ()
+
+         name     ← (getXPathTreesInDoc "/page/@name/text()" ⋙ getText) ⤙ page
+         isLocked ← (getXPathTreesInDoc "/page/@isLocked/text()" ⋙ getText ⋙ parseYesOrNo) ⤙ page
+
+         let cssHref   = [uriToString id (mkObjectURI baseURI styleSheet) ""]
+             scriptSrc = [uriToString id (baseURI { uriPath = uriPath baseURI </> "js" }) ""]
+
+         pageTitle    ← listA (readSubPage env) ⤙ (T.pack name, Just page, "PageTitle")
+         leftSideBar  ← listA (readSubPage env) ⤙ (T.pack name, Just page, "SideBar/Left")
+         rightSideBar ← listA (readSubPage env) ⤙ (T.pack name, Just page, "SideBar/Right")
+         pageBody     ← listA (makeMainXHTML (envStorage env) (envSysConf env) (envInterpTable env)) ⤙ page
+
+         ( eelem "/"
+           += ( eelem "html"
+                += sattr "xmlns" "http://www.w3.org/1999/xhtml"
+                += ( getXPathTreesInDoc "/page/@lang"
+                     `guards`
+                     qattr (mkQName "xml" "lang" "")
+                               ( getXPathTreesInDoc "/page/@lang/text()" )
+                   )
+                += ( eelem "head"
+                     += ( eelem "title"
+                          += txt (T.unpack siteName)
+                          += txt " - "
+                          += getXPathTreesInDoc "/page/@name/text()"
+                        )
+                     += ( constL cssHref
+                          ⋙
+                          eelem "link"
+                          += sattr "rel"  "stylesheet"
+                          += sattr "type" "text/css"
+                          += attr "href" (arr id ⋙ mkText)
+                        )
+                     += mkFeedList env
+                     += ( constL scriptSrc
+                          ⋙
+                          eelem "script"
+                          += sattr "type" "text/javascript"
+                          += attr "src" (arr id ⋙ mkText)
+                        )
+                     += ( eelem "script"
+                          += sattr "type" "text/javascript"
+                          += txt ("Rakka.baseURI=\""      ⊕ uriToString id baseURI "" ⊕ "\";")
+                          += txt ("Rakka.isLocked="       ⊕ trueOrFalse isLocked      ⊕ ";"  )
+                          += txt ("Rakka.isGlobalLocked=" ⊕ trueOrFalse isGLocked     ⊕ ";"  )
+                        )
+                     += mkGlobalJSList env
+                   )
+                += ( eelem "body"
+                     += ( eelem "div"
+                          += sattr "class" "header"
+                        )
+                     += ( eelem "div"
+                          += sattr "class" "center"
+                          += ( eelem "div"
+                               += sattr "class" "title"
+                               += constL pageTitle
+                             )
+                          += ( eelem "div"
+                               += sattr "class" "body"
+                               += constL pageBody
+                             )
+                        )
+                     += ( eelem "div"
+                          += sattr "class" "footer"
+                        )
+                     += ( eelem "div"
+                          += sattr "class" "left sideBar"
+                          += ( eelem "div"
+                               += sattr "class" "content"
+                               += constL leftSideBar
+                             )
+                        )
+                     += ( eelem "div"
+                          += sattr "class" "right sideBar"
+                          += ( eelem "div"
+                               += sattr "class" "content"
+                               += constL rightSideBar
+                             )
+                        )
+                   )
+                ⋙
+                uniqueNamespacesFromDeclAndQNames
+              ) ) ⤛ page
+
+entityToRSS ∷ (ArrowXml (⇝), ArrowChoice (⇝), ArrowIO (⇝))
+            ⇒ Environment
+            → XmlTree ⇝ XmlTree

 entityToRSS env
     = proc page
 entityToRSS env
     = proc page

-    -> do SiteName   siteName   <- getSysConfA (envSysConf env) -< ()
-          BaseURI    baseURI    <- getSysConfA (envSysConf env) -< ()
+    → do SiteName siteName ← getSysConfA (envSysConf env) ⤙ ()
+         BaseURI  baseURI  ← getSysConfA (envSysConf env) ⤙ ()

 
 

-          name    <- (getXPathTreesInDoc "/page/@name/text()" >>> getText) -< page
-          summary <- maybeA (getXPathTreesInDoc "/page/summary/text()" >>> getText) -< page
-          pages   <- makePageLinkList (envStorage env) (envSysConf env) (envInterpTable env) -< page
+         name    ← (getXPathTreesInDoc "/page/@name/text()" ⋙ getText) ⤙ page
+         summary ← maybeA (getXPathTreesInDoc "/page/summary/text()" ⋙ getText) ⤙ page
+         pages   ← makePageLinkList (envStorage env) (envSysConf env) (envInterpTable env) ⤙ page

           
           

-          ( eelem "/"
-            += ( eelem "rdf:RDF"
-                 += sattr "xmlns"           "http://purl.org/rss/1.0/"
-                 += sattr "xmlns:rdf"       "http://www.w3.org/1999/02/22-rdf-syntax-ns#"
-                 += sattr "xmlns:dc"        "http://purl.org/dc/elements/1.1/"
-                 += sattr "xmlns:trackback" "http://madskills.com/public/xml/rss/module/trackback/"
-                 += ( eelem "channel"
-                      += sattr "rdf:about" (uriToString id (mkFeedURI baseURI name) "")
-                      += ( eelem "title"
-                           += txt siteName
-                           += txt " - "
-                           += getXPathTreesInDoc "/page/@name/text()"
-                         )
-                      += ( eelem "link"
-                           += txt (uriToString id baseURI "")
-                         )
-                      += ( eelem "description"
-                           += txt (case summary of
-                                     Nothing -> "RSS Feed for " ++ siteName
-                                     Just s  -> s)
-                         )
-                      += ( eelem "items"
-                           += ( eelem "rdf:Seq"
-                                += ( constL pages
-                                     >>>
-                                     eelem "rdf:li"
-                                     += attr "resource" (arr (mkPageURIStr baseURI) >>> mkText)
-                                   )
-                              )
-                         )
-                    )
-                 += ( constL pages
-                      >>>
-                      arr (\ n -> (n, Nothing))
-                      >>>
-                      getPageA (envStorage env)
-                      >>>
-                      arr fromJust
-                      >>>
-                      eelem "item"
-                      += attr "rdf:about" (arr (mkPageURIStr baseURI . entityName) >>> mkText)
-                      += ( eelem "title"
-                           += (arr entityName >>> mkText)
-                         )
-                      += ( eelem "link"
-                           += (arr (mkPageURIStr baseURI . entityName) >>> mkText)
-                         )
-                      += ( arrL (\ p -> case entitySummary p of
-                                          Nothing -> []
-                                          Just s  -> [s])
-                           >>>
-                           eelem "description"
-                           += mkText
-                         )
-                      += ( eelem "dc:date"
-                           += ( arrIO (utcToLocalZonedTime . entityLastMod)
-                                >>>
-                                arr formatW3CDateTime
-                                >>>
-                                mkText
-                              )
-                         )
-                      += ( eelem "trackback:ping"
-                           += attr "rdf:resource" (arr (mkTrackbackURIStr baseURI . entityName) >>> mkText)
-                         )
-                    )
-                 >>>
-                 uniqueNamespacesFromDeclAndQNames
-               ) ) -<< page
+         ( eelem "/"
+           += ( eelem "rdf:RDF"
+                += sattr "xmlns"           "http://purl.org/rss/1.0/"
+                += sattr "xmlns:rdf"       "http://www.w3.org/1999/02/22-rdf-syntax-ns#"
+                += sattr "xmlns:dc"        "http://purl.org/dc/elements/1.1/"
+                += sattr "xmlns:trackback" "http://madskills.com/public/xml/rss/module/trackback/"
+                += ( eelem "channel"
+                     += sattr "rdf:about" (uriToString id (mkFeedURI baseURI (T.pack name)) "")
+                     += ( eelem "title"
+                          += txt (T.unpack siteName)
+                          += txt " - "
+                          += getXPathTreesInDoc "/page/@name/text()"
+                        )
+                     += ( eelem "link"
+                          += txt (uriToString id baseURI "")
+                        )
+                     += ( eelem "description"
+                          += txt (case summary of
+                                    Nothing → "RSS Feed for " ⊕ T.unpack siteName
+                                    Just s  → s)
+                        )
+                     += ( eelem "items"
+                          += ( eelem "rdf:Seq"
+                               += ( constL pages
+                                    ⋙
+                                    eelem "rdf:li"
+                                    += attr "resource" (arr (mkPageURIStr baseURI) ⋙ mkText) ) ) ) )
+                += ( constL pages
+                     ⋙
+                     arr (\n → (n, Nothing))
+                     ⋙
+                     getPageA (envStorage env)
+                     ⋙
+                     arr fromJust
+                     ⋙
+                     eelem "item"
+                     += attr "rdf:about" (arr (mkPageURIStr baseURI ∘ entityName) ⋙ mkText)
+                     += ( eelem "title"
+                          += (arr (T.unpack ∘ entityName) ⋙ mkText)
+                        )
+                     += ( eelem "link"
+                          += (arr (mkPageURIStr baseURI ∘ entityName) ⋙ mkText)
+                        )
+                     += ( arrL (\p → case entitySummary p of
+                                       Nothing → []
+                                       Just s  → [s])
+                          ⋙
+                          eelem "description"
+                          += mkText
+                        )
+                     += ( eelem "dc:date"
+                          += ( arrIO (utcToLocalZonedTime . entityLastMod)
+                               ⋙
+                               arr formatW3CDateTime
+                               ⋙
+                               mkText
+                             )
+                        )
+                     += ( eelem "trackback:ping"
+                          += attr "rdf:resource" (arr (mkTrackbackURIStr baseURI . entityName) ⋙ mkText)
+                        )
+                   )
+                ⋙
+                uniqueNamespacesFromDeclAndQNames
+              ) ) ⤛ page

     where
     where

-      mkPageURIStr :: URI -> PageName -> String
+      mkPageURIStr :: URI → PageName → String

       mkPageURIStr baseURI name
             = uriToString id (mkPageURI baseURI name) ""
 
       mkPageURIStr baseURI name
             = uriToString id (mkPageURI baseURI name) ""
 

-      mkTrackbackURIStr :: URI -> PageName -> String
+      mkTrackbackURIStr :: URI → PageName → String

       mkTrackbackURIStr baseURI name
             = uriToString id (mkAuxiliaryURI baseURI ["trackback"] name) ""
 
       mkTrackbackURIStr baseURI name
             = uriToString id (mkAuxiliaryURI baseURI ["trackback"] name) ""
 

-
-readSubPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
-               Environment
-            -> a (PageName, Maybe XmlTree, PageName) XmlTree
+readSubPage ∷ (ArrowXml (⇝), ArrowChoice (⇝), ArrowIO (⇝))
+            ⇒ Environment
+            → (PageName, Maybe XmlTree, PageName) ⇝ XmlTree

 readSubPage env
 readSubPage env

-    = proc (mainPageName, mainPage, subPageName) ->
-      do langM        <- case mainPage of
+    = proc (mainPageName, mainPage, subPageName) →
+      do langM        ← case mainPage of

                            Nothing
                            Nothing

-                               -> returnA -< Nothing
+                               → returnA ⤙ Nothing

                            Just p
                            Just p

-                               -> maybeA (getXPathTreesInDoc "/page/@lang/text()" >>> getText) -< p
-         subPage      <- getPageA (envStorage env) >>> arr fromJust -< (subPageName, Nothing)
-         localSubPage <- case langM of
+                               → maybeA (getXPathTreesInDoc "/page/@lang/text()" ⋙ getText) ⤙ p
+         subPage      ← getPageA (envStorage env) ⋙ arr fromJust ⤙ (subPageName, Nothing)
+         localSubPage ← case langM of

                            Nothing
                            Nothing

-                               -> returnA -< subPage
+                               → returnA ⤙ subPage

                            Just l
                            Just l

-                               -> localize (envStorage env) -< (l, subPage)
-         subPageXml   <- xmlizePage -< localSubPage
-         subXHTML     <- makeSubXHTML (envStorage env) (envSysConf env) (envInterpTable env)
-                         -< (Just mainPageName, mainPage, subPageXml)
-         returnA -< subXHTML
+                               → localize (envStorage env) ⤙ (CI.mk $ T.pack l, subPage)
+         subPageXml   ← xmlizePage ⤙ localSubPage
+         subXHTML     ← makeSubXHTML (envStorage env) (envSysConf env) (envInterpTable env)
+                         ⤙ (Just mainPageName, mainPage, subPageXml)
+         returnA ⤙ subXHTML

     where
     where

-      localize :: (ArrowChoice a, ArrowIO a) => Storage -> a (LanguageTag, Page) Page
+      localize ∷ (ArrowChoice (⇝), ArrowIO (⇝)) ⇒ Storage → (LanguageTag, Page) ⇝ Page

       localize sto
           = proc (lang, origPage)
       localize sto
           = proc (lang, origPage)

-          -> do let otherLang = entityOtherLang origPage
-                    localName = M.lookup lang otherLang
-                case localName of
-                  Nothing
-                      -> returnA -< origPage
-                  Just ln
-                      -> do localPage <- getPageA sto -< (ln, Nothing)
-                            returnA -< case localPage of
-                                         Nothing -> origPage
-                                         Just p  -> p
+          → do let otherLang = entityOtherLang origPage
+                   localName = M.lookup lang otherLang
+               case localName of
+                 Nothing
+                     → returnA ⤙ origPage
+                 Just ln
+                     → do localPage ← getPageA sto ⤙ (ln, Nothing)
+                          returnA ⤙ case localPage of
+                                       Nothing → origPage
+                                       Just p  → p

 
 
 {-
 
 
 {-


@@ -327,251 +341,247 @@ readSubPage env
     <page name="Foo/Baz" />
   </pageListing>
 -}
     <page name="Foo/Baz" />
   </pageListing>
 -}

-handleGetPageListing :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a (PageName, [PageName]) (Resource ())
+handleGetPageListing ∷ (ArrowXml (⇝), ArrowChoice (⇝), ArrowIO (⇝))
+                     ⇒ Environment
+                     → (PageName, [PageName]) ⇝ Resource ()

 handleGetPageListing env
     = proc (dir, items)
 handleGetPageListing env
     = proc (dir, items)

-    -> do tree <- ( eelem "/"
-                    += ( eelem "pageListing"
-                         += attr "path" (arr fst >>> mkText)
-                         += ( arrL snd
-                              >>> 
-                              ( eelem "page"
-                                += attr "name" (arr id >>> mkText)
-                              )
+    → do tree ← ( eelem "/"
+                  += ( eelem "pageListing"
+                       += attr "path" (arr (T.unpack ∘ fst) ⋙ mkText)
+                       += ( arrL snd
+                            ⋙ 
+                            ( eelem "page"
+                              += attr "name" (arr (T.unpack ∘ id) ⋙ mkText)

                             )
                             )

-                       )
-                  ) -< (dir, items)
-          returnA -< outputXmlPage' tree (pageListingToXHTML env) -- FIXME: rss 對應
-
-
-pageListingToXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a XmlTree XmlTree
+                          )
+                     )
+                ) ⤙ (dir, items)
+         returnA ⤙ outputXmlPage' tree (pageListingToXHTML env) -- FIXME: rss 對應
+
+pageListingToXHTML ∷ (ArrowXml (⇝), ArrowChoice (⇝), ArrowIO (⇝))
+                   ⇒ Environment
+                   → XmlTree ⇝ XmlTree

 pageListingToXHTML env
     = proc pageListing
 pageListingToXHTML env
     = proc pageListing

-    -> do SiteName   siteName   <- getSysConfA (envSysConf env) -< ()
-          BaseURI    baseURI    <- getSysConfA (envSysConf env) -< ()
-          StyleSheet styleSheet <- getSysConfA (envSysConf env) -< ()
-          GlobalLock isGLocked  <- getSysConfA (envSysConf env) -< ()
-
-          name <- (getXPathTreesInDoc "/pageListing/@path/text()" >>> getText) -< pageListing
-
-          let cssHref   = [uriToString id (mkObjectURI baseURI styleSheet) ""]
-              scriptSrc = [uriToString id (baseURI { uriPath = uriPath baseURI </> "js" }) ""]
-
-          pageTitle    <- listA (readSubPage env) -< (name, Nothing, "PageTitle")
-          leftSideBar  <- listA (readSubPage env) -< (name, Nothing, "SideBar/Left")
-          rightSideBar <- listA (readSubPage env) -< (name, Nothing, "SideBar/Right")
-
-          ( eelem "/"
-            += ( eelem "html"
-                 += sattr "xmlns" "http://www.w3.org/1999/xhtml"
-                 += ( eelem "head"
-                      += ( eelem "title"
-                           += txt siteName
-                           += txt " - "
-                           += getXPathTreesInDoc "/pageListing/@path/text()"
-                         )
-                      += ( constL cssHref
-                           >>>
-                           eelem "link"
-                           += sattr "rel"  "stylesheet"
-                           += sattr "type" "text/css"
-                           += attr "href" (arr id >>> mkText)
-                         )
-                      += mkFeedList env
-                      += ( constL scriptSrc
-                           >>>
-                           eelem "script"
-                           += sattr "type" "text/javascript"
-                           += attr "src" (arr id >>> mkText)
-                         )
-                      += ( eelem "script"
-                           += sattr "type" "text/javascript"
-                           += txt ("Rakka.baseURI = \"" ++ uriToString id baseURI "" ++ "\";")
-                           += txt ("Rakka.isGlobalLocked=" ++ trueOrFalse isGLocked ++ ";")
-                         )
-                      += mkGlobalJSList env
-                    )
-                 += ( eelem "body"
-                      += ( eelem "div"
-                           += sattr "class" "header"
-                         )
-                      += ( eelem "div"
-                           += sattr "class" "center"
-                           += ( eelem "div"
-                                += sattr "class" "title"
-                                += constL pageTitle
-                              )
-                           += ( eelem "div"
-                                += sattr "class" "body"
-                                += ( eelem "ul"
-                                     += ( getXPathTreesInDoc "/pageListing/page/@name/text()"
-                                          >>>
-                                          eelem "li"
-                                          += ( eelem "a"
-                                               += attr "href" ( getText
-                                                                >>>
-                                                                arr (\ x -> uriToString id (mkPageURI baseURI x) "")
-                                                                >>>
-                                                                mkText
-                                                              )
-                                               += this
-                                             )
-                                        )
-                                   )
-                              )
-                         )
-                      += ( eelem "div"
-                           += sattr "class" "footer"
-                         )
-                      += ( eelem "div"
-                           += sattr "class" "left sideBar"
-                           += ( eelem "div"
-                                += sattr "class" "content"
-                                += constL leftSideBar
-                              )
-                         )
-                      += ( eelem "div"
-                           += sattr "class" "right sideBar"
-                           += ( eelem "div"
-                                += sattr "class" "content"
-                                += constL rightSideBar
-                              )
-                         )
-                    )
-                 >>>
-                 uniqueNamespacesFromDeclAndQNames
-               ) ) -<< pageListing
-
+    → do SiteName   siteName   ← getSysConfA (envSysConf env) ⤙ ()
+         BaseURI    baseURI    ← getSysConfA (envSysConf env) ⤙ ()
+         StyleSheet styleSheet ← getSysConfA (envSysConf env) ⤙ ()
+         GlobalLock isGLocked  ← getSysConfA (envSysConf env) ⤙ ()
+
+         name ← (getXPathTreesInDoc "/pageListing/@path/text()" ⋙ getText) ⤙ pageListing
+
+         let cssHref   = [uriToString id (mkObjectURI baseURI styleSheet) ""]
+             scriptSrc = [uriToString id (baseURI { uriPath = uriPath baseURI </> "js" }) ""]
+
+         pageTitle    ← listA (readSubPage env) ⤙ (T.pack name, Nothing, "PageTitle")
+         leftSideBar  ← listA (readSubPage env) ⤙ (T.pack name, Nothing, "SideBar/Left")
+         rightSideBar ← listA (readSubPage env) ⤙ (T.pack name, Nothing, "SideBar/Right")
+
+         ( eelem "/"
+           += ( eelem "html"
+                += sattr "xmlns" "http://www.w3.org/1999/xhtml"
+                += ( eelem "head"
+                     += ( eelem "title"
+                          += txt (T.unpack siteName)
+                          += txt " - "
+                          += getXPathTreesInDoc "/pageListing/@path/text()"
+                        )
+                     += ( constL cssHref
+                          ⋙
+                          eelem "link"
+                          += sattr "rel"  "stylesheet"
+                          += sattr "type" "text/css"
+                          += attr "href" (arr id ⋙ mkText)
+                        )
+                     += mkFeedList env
+                     += ( constL scriptSrc
+                          ⋙
+                          eelem "script"
+                          += sattr "type" "text/javascript"
+                          += attr "src" (arr id ⋙ mkText)
+                        )
+                     += ( eelem "script"
+                          += sattr "type" "text/javascript"
+                          += txt ("Rakka.baseURI = \"" ++ uriToString id baseURI "" ++ "\";")
+                          += txt ("Rakka.isGlobalLocked=" ++ trueOrFalse isGLocked ++ ";")
+                        )
+                     += mkGlobalJSList env
+                   )
+                += ( eelem "body"
+                     += ( eelem "div"
+                          += sattr "class" "header"
+                        )
+                     += ( eelem "div"
+                          += sattr "class" "center"
+                          += ( eelem "div"
+                               += sattr "class" "title"
+                               += constL pageTitle
+                             )
+                          += ( eelem "div"
+                               += sattr "class" "body"
+                               += ( eelem "ul"
+                                    += ( getXPathTreesInDoc "/pageListing/page/@name/text()"
+                                         ⋙
+                                         eelem "li"
+                                         += ( eelem "a"
+                                              += attr "href" ( getText
+                                                               ⋙
+                                                               arr (\ x → uriToString id (mkPageURI baseURI (T.pack x)) "")
+                                                               ⋙
+                                                               mkText
+                                                             )
+                                              += this
+                                            ) ) ) ) )
+                     += ( eelem "div"
+                          += sattr "class" "footer"
+                        )
+                     += ( eelem "div"
+                          += sattr "class" "left sideBar"
+                          += ( eelem "div"
+                               += sattr "class" "content"
+                               += constL leftSideBar
+                             )
+                        )
+                     += ( eelem "div"
+                          += sattr "class" "right sideBar"
+                          += ( eelem "div"
+                               += sattr "class" "content"
+                               += constL rightSideBar
+                             )
+                        )
+                   )
+                ⋙
+                uniqueNamespacesFromDeclAndQNames
+              ) ) ⤛ pageListing

 
 {-
   <pageNotFound name="Foo/Bar" />
 -}
 
 {-
   <pageNotFound name="Foo/Bar" />
 -}

-handlePageNotFound :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a PageName (Resource ())
+handlePageNotFound ∷ (ArrowXml (⇝), ArrowChoice (⇝), ArrowIO (⇝))
+                   ⇒ Environment
+                   → PageName ⇝ Resource ()

 handlePageNotFound env
     = proc name
 handlePageNotFound env
     = proc name

-    -> do tree <- ( eelem "/"
-                    += ( eelem "pageNotFound"
-                         += attr "name" (arr id >>> mkText)
-                       )
-                  ) -< name
-          returnA -< do setStatus NotFound
-                        outputXmlPage' tree (notFoundToXHTML env)
-
-
-notFoundToXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a XmlTree XmlTree
+    → do tree ← ( eelem "/"
+                  += ( eelem "pageNotFound"
+                       += attr "name" (arr T.unpack ⋙ mkText)
+                     )
+                ) ⤙ name
+         returnA ⤙ do setStatus NotFound
+                      outputXmlPage' tree (notFoundToXHTML env)
+
+notFoundToXHTML ∷ (ArrowXml (⇝), ArrowChoice (⇝), ArrowIO (⇝))
+                ⇒ Environment
+                → XmlTree ⇝ XmlTree

 notFoundToXHTML env
     = proc pageNotFound
 notFoundToXHTML env
     = proc pageNotFound

-    -> do SiteName   siteName   <- getSysConfA (envSysConf env) -< ()
-          BaseURI    baseURI    <- getSysConfA (envSysConf env) -< ()
-          StyleSheet styleSheet <- getSysConfA (envSysConf env) -< ()
-          GlobalLock isGLocked  <- getSysConfA (envSysConf env) -< ()
-
-          name <- (getXPathTreesInDoc "/pageNotFound/@name/text()" >>> getText) -< pageNotFound
-
-          let cssHref   = [uriToString id (mkObjectURI baseURI styleSheet) ""]
-              scriptSrc = [uriToString id (baseURI { uriPath = uriPath baseURI </> "js" }) ""]
-
-          pageTitle    <- listA (readSubPage env) -< (name, Nothing, "PageTitle")
-          leftSideBar  <- listA (readSubPage env) -< (name, Nothing, "SideBar/Left")
-          rightSideBar <- listA (readSubPage env) -< (name, Nothing, "SideBar/Right")
-
-          ( eelem "/"
-            += ( eelem "html"
-                 += sattr "xmlns" "http://www.w3.org/1999/xhtml"
-                 += ( eelem "head"
-                      += ( eelem "title"
-                           += txt siteName
-                           += txt " - "
-                           += getXPathTreesInDoc "/pageNotFound/@name/text()"
-                         )
-                      += ( constL cssHref
-                           >>>
-                           eelem "link"
-                           += sattr "rel"  "stylesheet"
-                           += sattr "type" "text/css"
-                           += attr "href" (arr id >>> mkText)
-                         )
-                      += mkFeedList env
-                      += ( constL scriptSrc
-                           >>>
-                           eelem "script"
-                           += sattr "type" "text/javascript"
-                           += attr "src" (arr id >>> mkText)
-                         )
-                      += ( eelem "script"
-                           += sattr "type" "text/javascript"
-                           += txt ("Rakka.baseURI = \"" ++ uriToString id baseURI "" ++ "\";")
-                           += txt ("Rakka.isGlobalLocked=" ++ trueOrFalse isGLocked ++ ";")
-                         )
-                      += mkGlobalJSList env
-                    )
-                 += ( eelem "body"
-                      += ( eelem "div"
-                           += sattr "class" "header"
-                         )
-                      += ( eelem "div"
-                           += sattr "class" "center"
-                           += ( eelem "div"
-                                += sattr "class" "title"
-                                += constL pageTitle
-                              )
-                           += ( eelem "div"
-                                += sattr "class" "body"
-                                += txt "404 Not Found (FIXME)" -- FIXME
-                              )
-                         )
-                      += ( eelem "div"
-                           += sattr "class" "footer"
-                         )
-                      += ( eelem "div"
-                           += sattr "class" "left sideBar"
-                           += ( eelem "div"
-                                += sattr "class" "content"
-                                += constL leftSideBar
-                              )
-                         )
-                      += ( eelem "div"
-                           += sattr "class" "right sideBar"
-                           += ( eelem "div"
-                                += sattr "class" "content"
-                                += constL rightSideBar
-                              )
-                         )
-                    )
-                 >>>
-                 uniqueNamespacesFromDeclAndQNames
-               ) ) -<< pageNotFound
-
-
-handlePut :: Environment -> PageName -> Resource ()
+    → do SiteName   siteName   ← getSysConfA (envSysConf env) ⤙ ()
+         BaseURI    baseURI    ← getSysConfA (envSysConf env) ⤙ ()
+         StyleSheet styleSheet ← getSysConfA (envSysConf env) ⤙ ()
+         GlobalLock isGLocked  ← getSysConfA (envSysConf env) ⤙ ()
+
+         name ← (getXPathTreesInDoc "/pageNotFound/@name/text()" ⋙ getText) ⤙ pageNotFound
+
+         let cssHref   = [uriToString id (mkObjectURI baseURI styleSheet) ""]
+             scriptSrc = [uriToString id (baseURI { uriPath = uriPath baseURI </> "js" }) ""]
+
+         pageTitle    ← listA (readSubPage env) ⤙ (T.pack name, Nothing, "PageTitle"    )
+         leftSideBar  ← listA (readSubPage env) ⤙ (T.pack name, Nothing, "SideBar/Left" )
+         rightSideBar ← listA (readSubPage env) ⤙ (T.pack name, Nothing, "SideBar/Right")
+
+         ( eelem "/"
+           += ( eelem "html"
+                += sattr "xmlns" "http://www.w3.org/1999/xhtml"
+                += ( eelem "head"
+                     += ( eelem "title"
+                          += txt (T.unpack siteName)
+                          += txt " - "
+                          += getXPathTreesInDoc "/pageNotFound/@name/text()"
+                        )
+                     += ( constL cssHref
+                          ⋙
+                          eelem "link"
+                          += sattr "rel"  "stylesheet"
+                          += sattr "type" "text/css"
+                          += attr "href" (arr id ⋙ mkText)
+                        )
+                     += mkFeedList env
+                     += ( constL scriptSrc
+                          ⋙
+                          eelem "script"
+                          += sattr "type" "text/javascript"
+                          += attr "src" (arr id ⋙ mkText)
+                        )
+                     += ( eelem "script"
+                          += sattr "type" "text/javascript"
+                          += txt ("Rakka.baseURI = \"" ++ uriToString id baseURI "" ++ "\";")
+                          += txt ("Rakka.isGlobalLocked=" ++ trueOrFalse isGLocked ++ ";")
+                        )
+                     += mkGlobalJSList env
+                   )
+                += ( eelem "body"
+                     += ( eelem "div"
+                          += sattr "class" "header"
+                        )
+                     += ( eelem "div"
+                          += sattr "class" "center"
+                          += ( eelem "div"
+                               += sattr "class" "title"
+                               += constL pageTitle
+                             )
+                          += ( eelem "div"
+                               += sattr "class" "body"
+                               += txt "404 Not Found (FIXME)" -- FIXME
+                             )
+                        )
+                     += ( eelem "div"
+                          += sattr "class" "footer"
+                        )
+                     += ( eelem "div"
+                          += sattr "class" "left sideBar"
+                          += ( eelem "div"
+                               += sattr "class" "content"
+                               += constL leftSideBar
+                             )
+                        )
+                     += ( eelem "div"
+                          += sattr "class" "right sideBar"
+                          += ( eelem "div"
+                               += sattr "class" "content"
+                               += constL rightSideBar
+                             )
+                        )
+                   )
+                ⋙
+                uniqueNamespacesFromDeclAndQNames
+              ) ) ⤛ pageNotFound
+
+handlePut ∷ Environment → PageName → Resource ()

 handlePut env name
 handlePut env name

-    = do userID <- getUserID env
-         runXmlA env "rakka-page-1.0.rng" $ proc tree
-             -> do page   <- parseXmlizedPage -< (name, tree)
-                   status <- putPageA (envStorage env) -< (userID, page)
-                   returnA  -< setStatus status
-
+    = do userID ← getUserID env
+         runXmlA "rakka-page-1.0.rng" $ proc tree
+             → do page   ← parseXmlizedPage ⤙ (name, tree)
+                  status ← putPageA (envStorage env) ⤙ (userID, page)
+                  returnA ⤙ setStatus status

 
 

-handleDelete :: Environment -> PageName -> Resource ()
+handleDelete ∷ Environment → PageName → Resource ()

 handleDelete env name
 handleDelete env name

-    = do userID <- getUserID env
-         status <- deletePage (envStorage env) userID name
+    = do userID ← getUserID env
+         status ← deletePage (envStorage env) userID name

          setStatus status
 
          setStatus status
 

-
-mkFeedList :: (ArrowIO a, ArrowXml a) => Environment -> a b XmlTree
+mkFeedList ∷ (ArrowIO (⇝), ArrowXml (⇝)) ⇒ Environment → β ⇝ XmlTree

 mkFeedList env
 mkFeedList env

-    = proc _ -> do SiteName siteName <- getSysConfA (envSysConf env) -< ()
-                   BaseURI  baseURI  <- getSysConfA (envSysConf env) -< ()
-
-                   feed <- unlistA <<< arrIO0 (findFeeds $ envStorage env) -< ()
-                   
-                   ( eelem "link"
-                     += sattr "rel"   "alternate"
-                     += sattr "type"  "application/rss+xml"
-                     += attr  "title" (txt siteName <+> txt " - " <+> mkText)
-                     += attr  "href"  (arr (mkFeedURIStr baseURI) >>> mkText) ) -<< feed
-
+    = proc _
+      → do SiteName siteName ← getSysConfA (envSysConf env) ⤙ ()
+           BaseURI  baseURI  ← getSysConfA (envSysConf env) ⤙ ()
+           feed ← unlistA ⋘ arrIO0 (findFeeds $ envStorage env) ⤙ ()
+           ( eelem "link"
+             += sattr "rel"   "alternate"
+             += sattr "type"  "application/rss+xml"
+             += attr  "title" (txt (T.unpack siteName) <+> txt " - " <+> (arr T.unpack ⋙ mkText))
+             += attr  "href"  (arr (mkFeedURIStr baseURI) ⋙ mkText) ) ⤛ feed

 
 findFeeds :: Storage -> IO [PageName]
 findFeeds sto
 
 findFeeds :: Storage -> IO [PageName]
 findFeeds sto


@@ -606,23 +616,18 @@ mkGlobalJSList env
                          | otherwise
                              -> none -< ()
 
                          | otherwise
                              -> none -< ()
 

-
-findJavaScripts :: Storage -> IO [PageName]
+findJavaScripts ∷ Storage → IO [PageName]

 findJavaScripts sto
 findJavaScripts sto

-    = do cond <- newCondition
+    = do cond ← newCondition

          setPhrase   cond "[UVSET]"
          addAttrCond cond "@title STRBW Global/"
          addAttrCond cond "@type  STRBW text/javascript"
          setOrder    cond "@uri STRA"
          setPhrase   cond "[UVSET]"
          addAttrCond cond "@title STRBW Global/"
          addAttrCond cond "@type  STRBW text/javascript"
          setOrder    cond "@uri STRA"

-         result <- searchPages sto cond
+         result ← searchPages sto cond

          return (map hpPageName $ srPages result)
 
          return (map hpPageName $ srPages result)
 

+mkFeedURIStr ∷ URI → PageName → String
+mkFeedURIStr = flip flip "" ∘ (uriToString id ∘) ∘ mkFeedURI

 
 

-mkFeedURIStr :: URI -> PageName -> String
-mkFeedURIStr baseURI name
-    = uriToString id (mkFeedURI baseURI name) ""
-
-
-mkObjectURIStr :: URI -> PageName -> String
-mkObjectURIStr baseURI name
-    = uriToString id (mkObjectURI baseURI name) ""
+mkObjectURIStr ∷ URI → PageName → String
+mkObjectURIStr = flip flip "" ∘ (uriToString id ∘) ∘ mkObjectURI

diff --git a/Rakka/Resource/Render.hs b/Rakka/Resource/Render.hs
index 64c159e495c39fc2aae2b88dc67ba501370c0cfc..302360e645830239f1a4fa06394cb2981b78ecc3 100644 (file)
--- a/Rakka/Resource/Render.hs
+++ b/Rakka/Resource/Render.hs
@@ -1,16 +1,24 @@
+{-# LANGUAGE
+    Arrows
+  , TypeOperators
+  , UnicodeSyntax
+  #-}

 module Rakka.Resource.Render
     ( resRender
     )
     where
 module Rakka.Resource.Render
     ( resRender
     )
     where

-

 import qualified Codec.Binary.UTF8.String as UTF8
 import           Control.Arrow
 import           Control.Arrow.ArrowIO
 import           Control.Arrow.ArrowList
 import qualified Codec.Binary.UTF8.String as UTF8
 import           Control.Arrow
 import           Control.Arrow.ArrowIO
 import           Control.Arrow.ArrowList

+import           Control.Arrow.Unicode

 import           Control.Monad.Trans
 import           Control.Monad.Trans

+import Control.Monad.Unicode

 import qualified Data.ByteString.Lazy as Lazy
 import qualified Data.ByteString.Lazy as Lazy

+import Data.Text as T

 import           Network.HTTP.Lucu
 import           OpenSSL.EVP.Base64
 import           Network.HTTP.Lucu
 import           OpenSSL.EVP.Base64

+import Prelude.Unicode

 import           Rakka.Environment
 import           Rakka.Page
 import           Rakka.Utils
 import           Rakka.Environment
 import           Rakka.Page
 import           Rakka.Utils


@@ -19,26 +27,23 @@ import           System.FilePath.Posix
 import           Text.XML.HXT.Arrow.Namespace
 import           Text.XML.HXT.Arrow.WriteDocument
 import           Text.XML.HXT.Arrow.XmlArrow
 import           Text.XML.HXT.Arrow.Namespace
 import           Text.XML.HXT.Arrow.WriteDocument
 import           Text.XML.HXT.Arrow.XmlArrow

-import           Text.XML.HXT.Arrow.XmlIOStateArrow
+import Text.XML.HXT.Arrow.XmlState

 import           Text.XML.HXT.DOM.TypeDefs
 import           Text.XML.HXT.DOM.TypeDefs

-import           Text.XML.HXT.DOM.XmlKeywords
-

 
 

-resRender :: Environment -> ResourceDef
+resRender ∷ Environment → ResourceDef

 resRender env
     = ResourceDef {
         resUsesNativeThread = False
       , resIsGreedy         = True
       , resGet              = Nothing
       , resHead             = Nothing
 resRender env
     = ResourceDef {
         resUsesNativeThread = False
       , resIsGreedy         = True
       , resGet              = Nothing
       , resHead             = Nothing

-      , resPost             = Just $ getPathInfo >>= handleRender env . toPageName
+      , resPost             = Just $ getPathInfo ≫= handleRender env ∘ toPageName

       , resPut              = Nothing
       , resDelete           = Nothing
       }
     where
       , resPut              = Nothing
       , resDelete           = Nothing
       }
     where

-      toPageName :: [String] -> PageName
-      toPageName = UTF8.decodeString . joinPath
-
+      toPageName ∷ [String] → PageName
+      toPageName = T.pack ∘ UTF8.decodeString ∘ joinPath

 
 {-
   --- Request ---
 
 {-
   --- Request ---


@@ -76,32 +81,30 @@ handleRender env name
                                   -> (entity, guessMIMEType entity)
 
          setContentType $ read "text/xml"
                                   -> (entity, guessMIMEType entity)
 
          setContentType $ read "text/xml"

-         [xmlStr] <- liftIO $ runX ( setErrorMsgHandler False fail
-                                     >>>
-                                     constA (name, cType, bin)
-                                     >>>
-                                     render env
-                                     >>>
-                                     writeDocumentToString [ (a_indent         , v_1)
-                                                           , (a_output_encoding, utf8)
-                                                           , (a_no_xml_pi      , v_0) ]
-                                   )
-         output xmlStr
+         [xmlStr] ← liftIO $ runX ( setErrorMsgHandler False fail
+                                    ⋙
+                                    constA (name, cType, bin)
+                                    ⋙
+                                    render env
+                                    ⋙
+                                    writeDocumentToString [ withIndent yes
+                                                          , withXmlPi  yes
+                                                          ]
+                                  )
+         output $ UTF8.encodeString xmlStr

 
 

-
-render :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
-          Environment
-       -> a (PageName, MIMEType, Lazy.ByteString) XmlTree
+render ∷ (ArrowXml (⇝), ArrowChoice (⇝), ArrowIO (⇝))
+       ⇒ Environment
+       → (PageName, MIMEType, Lazy.ByteString) ⇝ XmlTree

 render env
     = proc (pName, pType, pBin)
 render env
     = proc (pName, pType, pBin)

-    -> do pageBody <- listA (makePreviewXHTML (envStorage env) (envSysConf env) (envInterpTable env))
-                      -< (pName, pType, pBin)
-
-          ( eelem "/"
-            += ( eelem "renderResult"
-                 += sattr "name" pName
-                 += constL pageBody
-                 >>>
-                 uniqueNamespacesFromDeclAndQNames
-               ) ) -<< ()
-
+    → do pageBody ← listA (makePreviewXHTML (envStorage env) (envSysConf env) (envInterpTable env))
+                    ⤙ (pName, pType, pBin)
+         ( eelem "/"
+           += ( eelem "renderResult"
+                += sattr "xmlns:xhtml" "http://www.w3.org/1999/xhtml"
+                += sattr "name" (T.unpack pName)
+                += constL pageBody
+                ⋙
+                uniqueNamespacesFromDeclAndQNames
+              ) ) ⤛ ()

diff --git a/Rakka/Resource/Search.hs b/Rakka/Resource/Search.hs
index 423bfdc3f32b921393c95892362dbf920f29431d..56f99c0118d148bdeb5fb91cd9a7308f14a06891 100644 (file)
--- a/Rakka/Resource/Search.hs
+++ b/Rakka/Resource/Search.hs
@@ -1,16 +1,31 @@
+{-# LANGUAGE
+    Arrows
+  , OverloadedStrings
+  , TypeOperators
+  , UnicodeSyntax
+  #-}

 module Rakka.Resource.Search
     ( resSearch
     )
     where
 module Rakka.Resource.Search
     ( resSearch
     )
     where

-
+import Control.Applicative
+import Control.Arrow
+import Control.Arrow.ArrowIf
+import Control.Arrow.ArrowIO
+import Control.Arrow.ArrowList
+import Control.Arrow.ArrowTree
+import Control.Arrow.Unicode

 import qualified Codec.Binary.UTF8.Generic as UTF8
 import           Control.Monad.Trans
 import qualified Codec.Binary.UTF8.Generic as UTF8
 import           Control.Monad.Trans

-import           Data.List

 import           Data.Maybe
 import           Data.Maybe

+import Data.Monoid.Unicode
+import Data.Text (Text)
+import qualified Data.Text as T

 import           Data.Time
 import           Data.Time

+import qualified Data.Time.RFC1123 as RFC1123

 import           Network.HTTP.Lucu
 import           Network.HTTP.Lucu

-import           Network.HTTP.Lucu.RFC1123DateTime

 import           Network.URI hiding (query, fragment)
 import           Network.URI hiding (query, fragment)

+import Prelude.Unicode

 import           Rakka.Environment
 import           Rakka.Page
 import           Rakka.Resource
 import           Rakka.Environment
 import           Rakka.Page
 import           Rakka.Resource


@@ -21,9 +36,10 @@ import           Rakka.W3CDateTime
 import           Rakka.Wiki.Engine
 import           System.FilePath
 import           Text.HyperEstraier hiding (getText)
 import           Rakka.Wiki.Engine
 import           System.FilePath
 import           Text.HyperEstraier hiding (getText)

-import           Text.XML.HXT.Arrow
-import           Text.XML.HXT.XPath
-
+import Text.XML.HXT.Arrow.Namespace
+import Text.XML.HXT.Arrow.XmlArrow
+import Text.XML.HXT.DOM.TypeDefs
+import Text.XML.HXT.XPath

 
 resSearch :: Environment -> ResourceDef
 resSearch env
 
 resSearch :: Environment -> ResourceDef
 resSearch env


@@ -45,11 +61,9 @@ resultsPerSection = 10
 maxSectionWindowSize :: Int
 maxSectionWindowSize = 10
 
 maxSectionWindowSize :: Int
 maxSectionWindowSize = 10
 

-
-findQueryParam :: String -> [FormData] -> Maybe String
+findQueryParam ∷ String → [(String, FormData)] → Maybe String

 findQueryParam name qps
 findQueryParam name qps

-    = do fd <- find (\ qp -> fdName qp == name) qps
-         return $ UTF8.toString $ fdContent fd
+    = UTF8.toString ∘ fdContent <$> lookup name qps

 
 {-
   <searchResult query="foo bar baz"
 
 {-
   <searchResult query="foo bar baz"


@@ -64,9 +78,9 @@ findQueryParam name qps
     ...
   </searchResult>
 -}
     ...
   </searchResult>
 -}

-handleSearch :: Environment -> Resource ()
+handleSearch ∷ Environment → Resource ()

 handleSearch env
 handleSearch env

-    = do params <- getQueryForm
+    = do params ← getQueryForm

 
          let query = fromMaybe "" $ findQueryParam "q" params
              order = findQueryParam "order" params
 
          let query = fromMaybe "" $ findQueryParam "q" params
              order = findQueryParam "order" params


@@ -75,224 +89,219 @@ handleSearch env
              to    = fromMaybe (from + resultsPerSection)
                      $ fmap read $ findQueryParam "to" params
 
              to    = fromMaybe (from + resultsPerSection)
                      $ fmap read $ findQueryParam "to" params
 

-         cond   <- liftIO $ mkCond query order from to
-         result <- searchPages (envStorage env) cond
+         cond   ← liftIO $ mkCond (T.pack query) (T.pack <$> order) from to
+         result ← searchPages (envStorage env) cond

 
          let to' = min (from + length (srPages result)) to
 
 
          let to' = min (from + length (srPages result)) to
 

-         BaseURI baseURI <- getSysConf (envSysConf env)
+         BaseURI baseURI ← getSysConf (envSysConf env)

          runIdempotentA baseURI $ proc ()
          runIdempotentA baseURI $ proc ()

-             -> do tree <- ( eelem "/"
-                             += ( eelem "searchResult"
-                                  += sattr "query" query
-                                  += ( case order of
-                                         Just o  -> sattr "order" o
-                                         Nothing -> none
-                                     )
-                                  += sattr "from"  (show from)
-                                  += sattr "to"    (show to')
-                                  += sattr "total" (show $ srTotal result)
-                                  += ( constL (srPages result)
-                                       >>>
-                                       mkPageElem
-                                     )
-                                )
-                           ) -< ()
-                   returnA -< outputXmlPage' tree (searchResultToXHTML env)
+             → do tree ← ( eelem "/"
+                           += ( eelem "searchResult"
+                                += sattr "query" query
+                                += ( case order of
+                                       Just o  → sattr "order" o
+                                       Nothing → none
+                                   )
+                                += sattr "from"  (show from)
+                                += sattr "to"    (show to')
+                                += sattr "total" (show $ srTotal result)
+                                += ( constL (srPages result)
+                                     ⋙
+                                     mkPageElem
+                                   )
+                              )
+                         ) ⤙ ()
+                  returnA ⤙ outputXmlPage' tree (searchResultToXHTML env)

     where
     where

-      mkCond :: String -> Maybe String -> Int -> Int -> IO Condition
+      mkCond ∷ Text → Maybe Text → Int → Int → IO Condition

       mkCond query order from to
       mkCond query order from to

-          = do cond <- newCondition
+          = do cond ← newCondition

                setPhrase cond query
                case order of
                setPhrase cond query
                case order of

-                 Just o  -> setOrder cond o
-                 Nothing -> return ()
-               setSkip   cond from
-               setMax    cond (to - from + 1)
-               return cond
+                 Just o  → setOrder cond o
+                 Nothing → return ()
+               setSkip cond from
+               setMax  cond (to - from + 1)
+               pure cond

 
 

-      mkPageElem :: (ArrowChoice a, ArrowXml a, ArrowIO a) => a HitPage XmlTree
+      mkPageElem ∷ (ArrowChoice (⇝), ArrowXml (⇝), ArrowIO (⇝)) ⇒ HitPage ⇝ XmlTree

       mkPageElem = ( eelem "page"
       mkPageElem = ( eelem "page"

-                     += attr "name" (arr hpPageName >>> mkText)
-                     += attr "lastModified" ( arrIO (utcToLocalZonedTime . hpLastMod)
-                                              >>>
+                     += attr "name" (arr (T.unpack ∘ hpPageName) ⋙ mkText)
+                     += attr "lastModified" ( arrIO (utcToLocalZonedTime ∘ hpLastMod)
+                                              ⋙

                                               arr formatW3CDateTime
                                               arr formatW3CDateTime

-                                              >>>
+                                              ⋙

                                               mkText
                                             )
                      += ( arrL hpSnippet
                                               mkText
                                             )
                      += ( arrL hpSnippet

-                          >>>
+                          ⋙

                           mkSnippetTree
                         )
                    )
 
                           mkSnippetTree
                         )
                    )
 

-      mkSnippetTree :: (ArrowChoice a, ArrowXml a) => a SnippetFragment XmlTree
+      mkSnippetTree ∷ (ArrowChoice (⇝), ArrowXml (⇝)) ⇒ SnippetFragment ⇝ XmlTree

       mkSnippetTree = proc fragment
       mkSnippetTree = proc fragment

-                    -> case fragment of
-                         Boundary          -> eelem "boundary" -< ()
-                         NormalText      t -> mkText           -< t
-                         HighlightedWord w -> ( eelem "hit"
-                                                += mkText
-                                              ) -< w
+                    → case fragment of
+                        Boundary          → eelem "boundary" ⤙ ()
+                        NormalText      t → mkText           ⤙ T.unpack t
+                        HighlightedWord w → ( eelem "hit"
+                                              += mkText
+                                            ) ⤙ T.unpack w

 
 

-
-searchResultToXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a XmlTree XmlTree
+searchResultToXHTML ∷ (ArrowXml (⇝), ArrowChoice (⇝), ArrowIO (⇝))
+                    ⇒ Environment
+                    → XmlTree ⇝ XmlTree

 searchResultToXHTML env
     = proc tree
 searchResultToXHTML env
     = proc tree

-    -> do SiteName   siteName   <- getSysConfA (envSysConf env) -< ()
-          BaseURI    baseURI    <- getSysConfA (envSysConf env) -< ()
-          StyleSheet styleSheet <- getSysConfA (envSysConf env) -< ()
-          GlobalLock isGLocked  <- getSysConfA (envSysConf env) -< ()
+    → do SiteName   siteName   ← getSysConfA (envSysConf env) ⤙ ()
+         BaseURI    baseURI    ← getSysConfA (envSysConf env) ⤙ ()
+         StyleSheet styleSheet ← getSysConfA (envSysConf env) ⤙ ()
+         GlobalLock isGLocked  ← getSysConfA (envSysConf env) ⤙ ()

 
 

-          let cssHref   = [uriToString id (mkObjectURI baseURI styleSheet) ""]
-              scriptSrc = [uriToString id (baseURI { uriPath = uriPath baseURI </> "js" }) ""]
+         let cssHref   = [uriToString id (mkObjectURI baseURI styleSheet) ""]
+             scriptSrc = [uriToString id (baseURI { uriPath = uriPath baseURI </> "js" }) ""]

 
 

-          pageTitle    <- listA (readSubPage env) -< "PageTitle"
-          leftSideBar  <- listA (readSubPage env) -< "SideBar/Left"
-          rightSideBar <- listA (readSubPage env) -< "SideBar/Right"
+         pageTitle    ← listA (readSubPage env) ⤙ "PageTitle"
+         leftSideBar  ← listA (readSubPage env) ⤙ "SideBar/Left"
+         rightSideBar ← listA (readSubPage env) ⤙ "SideBar/Right"

 
 

-          ( eelem "/"
-            += ( eelem "html"
-                 += sattr "xmlns" "http://www.w3.org/1999/xhtml"
-                 += ( eelem "head"
-                      += ( eelem "title"
-                           += txt siteName
-                           += txt " - "
-                           += getXPathTreesInDoc "/searchResult/@query/text()"
-                         )
-                      += ( constL cssHref
-                           >>>
-                           eelem "link"
-                           += sattr "rel"  "stylesheet"
-                           += sattr "type" "text/css"
-                           += attr "href" (arr id >>> mkText)
-                         )
-                      += ( constL scriptSrc
-                           >>>
-                           eelem "script"
-                           += sattr "type" "text/javascript"
-                           += attr "src" (arr id >>> mkText)
-                         )
-                      += ( eelem "script"
-                           += sattr "type" "text/javascript"
-                           += txt ("Rakka.baseURI=\"" ++ uriToString id baseURI "" ++ "\";")
-                           += txt ("Rakka.isGlobalLocked=" ++ trueOrFalse isGLocked ++ ";")
-                           += txt  "Rakka.isSpecialPage=true;"
-                         )
-                    )
-                 += ( eelem "body"
-                      += ( eelem "div"
-                           += sattr "class" "header"
-                         )
-                      += ( eelem "div"
-                           += sattr "class" "center"
-                           += ( eelem "div"
-                                += sattr "class" "title"
-                                += constL pageTitle
-                              )
-                           += ( eelem "div"
-                                += sattr "class" "body"
-                                += ( eelem "h1"
-                                     += txt "Search Result"
-                                   )
-                                += ( eelem "div"
-                                     += sattr "class" "searchStat"
-                                     += txt "Search result for "
-                                     += ( eelem "span"
-                                          += sattr "class" "queryString"
-                                          += getXPathTreesInDoc "/searchResult/@query/text()"
-                                        )
-                                     += txt ": found "
-                                     += getXPathTreesInDoc "/searchResult/@total/text()"
-                                     += txt " pages."
-                                   )
-                                += ( getXPathTreesInDoc "/searchResult/page"
-                                     >>>
-                                     formatItem baseURI
-                                   )
-                                += ( ( ( getXPathTreesInDoc "/searchResult/@query/text()"
-                                         >>>
-                                         getText
-                                       )
-                                       &&&
-                                       maybeA ( getXPathTreesInDoc "/searchResult/@order/text()"
-                                                >>>
-                                                getText
-                                              )
-                                       &&&
-                                       ( getXPathTreesInDoc "/searchResult/@from/text()"
-                                         >>>
-                                         getText
-                                         >>>
-                                         arr ((`div` resultsPerSection) . read)
-                                       )
-                                       &&&
-                                       ( getXPathTreesInDoc "/searchResult/@total/text()"
-                                         >>>
-                                         getText
-                                         >>>
-                                         arr ((+ 1) . (`div` resultsPerSection) . (\ x -> x - 1) . read)
+         ( eelem "/"
+           += ( eelem "html"
+                += sattr "xmlns" "http://www.w3.org/1999/xhtml"
+                += ( eelem "head"
+                     += ( eelem "title"
+                          += txt (T.unpack siteName)
+                          += txt " - "
+                          += getXPathTreesInDoc "/searchResult/@query/text()"
+                        )
+                     += ( constL cssHref
+                          ⋙
+                          eelem "link"
+                          += sattr "rel"  "stylesheet"
+                          += sattr "type" "text/css"
+                          += attr "href" (arr id ⋙ mkText)
+                        )
+                     += ( constL scriptSrc
+                          ⋙
+                          eelem "script"
+                          += sattr "type" "text/javascript"
+                          += attr "src" (arr id ⋙ mkText)
+                        )
+                     += ( eelem "script"
+                          += sattr "type" "text/javascript"
+                          += txt ("Rakka.baseURI=\""      ⊕ uriToString id baseURI "" ⊕ "\";")
+                          += txt ("Rakka.isGlobalLocked=" ⊕ trueOrFalse isGLocked     ⊕ ";"  )
+                          += txt  "Rakka.isSpecialPage=true;" ) )
+                += ( eelem "body"
+                     += ( eelem "div"
+                          += sattr "class" "header"
+                        )
+                     += ( eelem "div"
+                          += sattr "class" "center"
+                          += ( eelem "div"
+                               += sattr "class" "title"
+                               += constL pageTitle
+                             )
+                          += ( eelem "div"
+                               += sattr "class" "body"
+                               += ( eelem "h1"
+                                    += txt "Search Result"
+                                  )
+                               += ( eelem "div"
+                                    += sattr "class" "searchStat"
+                                    += txt "Search result for "
+                                    += ( eelem "span"
+                                         += sattr "class" "queryString"
+                                         += getXPathTreesInDoc "/searchResult/@query/text()"

                                        )
                                        )

-                                     )
-                                     >>>
-                                     ( ((> 1) . snd . snd . snd)
-                                       `guardsP`
-                                       formatPager baseURI
-                                     )
-                                   )
-                              )
-                         )
-                      += ( eelem "div"
-                           += sattr "class" "footer"
-                         )
-                      += ( eelem "div"
-                           += sattr "class" "left sideBar"
-                           += ( eelem "div"
-                                += sattr "class" "content"
-                                += constL leftSideBar
-                              )
-                         )
-                      += ( eelem "div"
-                           += sattr "class" "right sideBar"
-                           += ( eelem "div"
-                                += sattr "class" "content"
-                                += constL rightSideBar
-                              )
-                         )
-                    )
-                 >>>
-                 uniqueNamespacesFromDeclAndQNames
-               ) ) -<< tree
+                                    += txt ": found "
+                                    += getXPathTreesInDoc "/searchResult/@total/text()"
+                                    += txt " pages."
+                                  )
+                               += ( getXPathTreesInDoc "/searchResult/page"
+                                    ⋙
+                                    formatItem baseURI
+                                  )
+                               += ( ( ( getXPathTreesInDoc "/searchResult/@query/text()"
+                                        ⋙
+                                        getText
+                                      )
+                                      &&&
+                                      maybeA ( getXPathTreesInDoc "/searchResult/@order/text()"
+                                               ⋙
+                                               getText
+                                             )
+                                      &&&
+                                      ( getXPathTreesInDoc "/searchResult/@from/text()"
+                                        ⋙
+                                        getText
+                                        ⋙
+                                        arr ((`div` resultsPerSection) . read)
+                                      )
+                                      &&&
+                                      ( getXPathTreesInDoc "/searchResult/@total/text()"
+                                        ⋙
+                                        getText
+                                        ⋙
+                                        arr ((+ 1) . (`div` resultsPerSection) . (\x → x - 1) . read) ) )
+                                    ⋙
+                                    ( ((> 1) . snd . snd . snd)
+                                      `guardsP`
+                                      formatPager baseURI ) ) ) )
+                     += ( eelem "div"
+                          += sattr "class" "footer"
+                        )
+                     += ( eelem "div"
+                          += sattr "class" "left sideBar"
+                          += ( eelem "div"
+                               += sattr "class" "content"
+                               += constL leftSideBar
+                             )
+                        )
+                     += ( eelem "div"
+                          += sattr "class" "right sideBar"
+                          += ( eelem "div"
+                               += sattr "class" "content"
+                               += constL rightSideBar
+                             )
+                        )
+                   )
+                ⋙
+                uniqueNamespacesFromDeclAndQNames
+              ) ) ⤛ tree

     where
     where

-      formatItem :: (ArrowXml a, ArrowChoice a, ArrowIO a) => URI -> a XmlTree XmlTree
+      formatItem ∷ (ArrowXml (⇝), ArrowChoice (⇝), ArrowIO (⇝))
+                 ⇒ URI
+                 → XmlTree ⇝ XmlTree

       formatItem baseURI
           = ( eelem "div"
               += sattr "class" "searchResult"
               += ( eelem "a"
                    += attr "href" ( getAttrValue "name"
       formatItem baseURI
           = ( eelem "div"
               += sattr "class" "searchResult"
               += ( eelem "a"
                    += attr "href" ( getAttrValue "name"

-                                    >>>
-                                    arr (\ x -> uriToString id (mkPageURI baseURI x) "")
-                                    >>>
+                                    ⋙
+                                    arr (\x → uriToString id (mkPageURI baseURI (T.pack x)) "")
+                                    ⋙

                                     mkText
                                   )
                                     mkText
                                   )

-                   += (getAttrValue "name" >>> mkText)
+                   += (getAttrValue "name" ⋙ mkText)

                  )
               += ( eelem "div"
                    += sattr "class" "date"
                    += ( getAttrValue "lastModified"
                  )
               += ( eelem "div"
                    += sattr "class" "date"
                    += ( getAttrValue "lastModified"

-                        >>>
+                        ⋙

                         arr (zonedTimeToUTC . fromJust . parseW3CDateTime)
                         arr (zonedTimeToUTC . fromJust . parseW3CDateTime)

-                        >>>
+                        ⋙

                         arrIO utcToLocalZonedTime
                         arrIO utcToLocalZonedTime

-                        >>>
-                        arr formatRFC1123DateTime
-                        >>>
+                        ⋙
+                        arr RFC1123.format
+                        ⋙

                         mkText
                       )
                  )
               += ( eelem "p"
                    += ( getChildren
                         mkText
                       )
                  )
               += ( eelem "p"
                    += ( getChildren

-                        >>>
+                        ⋙

                         choiceA [ isText             :-> this
                                 , hasName "boundary" :-> txt " ... "
                                 , hasName "hit"      :-> ( eelem "span"
                         choiceA [ isText             :-> this
                                 , hasName "boundary" :-> txt " ... "
                                 , hasName "hit"      :-> ( eelem "span"


@@ -316,29 +325,29 @@ searchResultToXHTML env
                      arr (fst . snd . snd)
                      &&&
                      ( arr (snd . snd)
                      arr (fst . snd . snd)
                      &&&
                      ( arr (snd . snd)

-                       >>>
+                       ⋙

                        mkSectionWindow
                      )
                    )
                        mkSectionWindow
                      )
                    )

-                   >>>
+                   ⋙

                    proc (query, (order, (currentSection, section)))
                        -> if currentSection == section then
                               ( txt " "
                                 <+> 
                                 eelem "span"
                                 += sattr "class" "currentSection"
                    proc (query, (order, (currentSection, section)))
                        -> if currentSection == section then
                               ( txt " "
                                 <+> 
                                 eelem "span"
                                 += sattr "class" "currentSection"

-                                += (arr show >>> mkText)
-                              ) -< section
+                                += (arr show ⋙ mkText)
+                              ) ⤙ section

                           else
                               ( txt " "
                                 <+>
                                 eelem "a"
                                 += attr "href" ( mkSectionURI baseURI
                           else
                               ( txt " "
                                 <+>
                                 eelem "a"
                                 += attr "href" ( mkSectionURI baseURI

-                                                 >>>
+                                                 ⋙

                                                  uriToText
                                                )
                                                  uriToText
                                                )

-                                += (arr (show . snd . snd) >>> mkText)
-                              ) -< (query, (order, section))
+                                += (arr (show . snd . snd) ⋙ mkText)
+                              ) ⤙ (query, (order, section))

                  )
             )
 
                  )
             )
 


@@ -358,7 +367,7 @@ searchResultToXHTML env
                                         -- どちらにも溢れない
                                         (windowBegin, windowBegin + windowWidth - 1)
              in
                                         -- どちらにも溢れない
                                         (windowBegin, windowBegin + windowWidth - 1)
              in

-               arrL id -< [begin .. end]
+               arrL id ⤙ [begin .. end]

                        
 
       mkSectionURI :: Arrow a => URI -> a (String, (Maybe String, Int)) URI
                        
 
       mkSectionURI :: Arrow a => URI -> a (String, (Maybe String, Int)) URI


@@ -378,7 +387,7 @@ searchResultToXHTML env
              }
 
       uriToText :: ArrowXml a => a URI XmlTree
              }
 
       uriToText :: ArrowXml a => a URI XmlTree

-      uriToText = arr (\ uri -> uriToString id uri "") >>> mkText
+      uriToText = arr (\ uri -> uriToString id uri "") ⋙ mkText

 
 
 -- FIXME: localize
 
 
 -- FIXME: localize


@@ -386,6 +395,6 @@ readSubPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
                Environment -> a PageName XmlTree
 readSubPage env
     = proc (subPageName) ->
                Environment -> a PageName XmlTree
 readSubPage env
     = proc (subPageName) ->

-      do subPage  <- getPageA (envStorage env) >>> arr fromJust >>> xmlizePage -< (subPageName, Nothing)
-         subXHTML <- makeSubXHTML (envStorage env) (envSysConf env) (envInterpTable env) -< (Nothing, Nothing, subPage)
-         returnA -< subXHTML
+      do subPage  ← getPageA (envStorage env) ⋙ arr fromJust ⋙ xmlizePage ⤙ (subPageName, Nothing)
+         subXHTML ← makeSubXHTML (envStorage env) (envSysConf env) (envInterpTable env) ⤙ (Nothing, Nothing, subPage)
+         returnA ⤙ subXHTML

diff --git a/Rakka/Resource/SystemConfig.hs b/Rakka/Resource/SystemConfig.hs
index cb19011b1f3c4b6746095b21e557668b57e41fca..3ae3f42952d0d08d78362a1eea8a141da5e07c97 100644 (file)
--- a/Rakka/Resource/SystemConfig.hs
+++ b/Rakka/Resource/SystemConfig.hs
@@ -1,16 +1,31 @@
+{-# LANGUAGE
+    Arrows
+  , RecordWildCards
+  , ScopedTypeVariables
+  , TypeOperators
+  , UnicodeSyntax
+  #-}

 module Rakka.Resource.SystemConfig
     ( resSystemConfig
     )
     where
 module Rakka.Resource.SystemConfig
     ( resSystemConfig
     )
     where

-
+import Control.Arrow
+import Control.Arrow.ArrowIf
+import Control.Arrow.ArrowIO
+import Control.Arrow.ArrowList
+import Control.Arrow.ArrowTree
+import Control.Arrow.Unicode

 import           Data.Maybe
 import           Data.Maybe

+import Data.Text (Text)
+import qualified Data.Text as T

 import           Network.HTTP.Lucu
 import           Network.HTTP.Lucu

+import Prelude.Unicode

 import           Rakka.Environment
 import           Rakka.Resource
 import           Rakka.SystemConfig
 import           Rakka.Environment
 import           Rakka.Resource
 import           Rakka.SystemConfig

-import           Text.XML.HXT.Arrow
-import           Text.XML.HXT.XPath
-
+import Text.XML.HXT.Arrow.XmlArrow
+import Text.XML.HXT.DOM.TypeDefs
+import Text.XML.HXT.XPath

 
 -- FIXME:
 -- GET /systemConfig          ==> 全設定値を返す
 
 -- FIXME:
 -- GET /systemConfig          ==> 全設定値を返す


@@ -28,7 +43,6 @@ resSystemConfig env
       , resDelete           = Nothing
       }
 
       , resDelete           = Nothing
       }
 

-

 {-
   <systemConfig>
     <value path="siteName">Rakka</value>
 {-
   <systemConfig>
     <value path="siteName">Rakka</value>


@@ -41,77 +55,72 @@ handleGet env
     -> do tree <- mkSystemConfigTree env -< ()
          returnA -< outputXml tree
 
     -> do tree <- mkSystemConfigTree env -< ()
          returnA -< outputXml tree
 

+mkSystemConfigTree ∷ (ArrowXml (⇝), ArrowIO (⇝)) ⇒ Environment → β ⇝ XmlTree
+mkSystemConfigTree (Environment {..})
+    = proc _ →
+      do siteName    @ (SiteName    _) ← getSysConfA envSysConf ⤙ ()
+         baseURI     @ (BaseURI     _) ← getSysConfA envSysConf ⤙ ()
+         defaultPage @ (DefaultPage _) ← getSysConfA envSysConf ⤙ ()
+         styleSheet  @ (StyleSheet  _) ← getSysConfA envSysConf ⤙ ()
+         languages   @ (Languages   _) ← getSysConfA envSysConf ⤙ ()
+         globalLock  @ (GlobalLock  _) ← getSysConfA envSysConf ⤙ ()

 
 

-mkSystemConfigTree :: (ArrowXml a, ArrowIO a) => Environment -> a b XmlTree
-mkSystemConfigTree env
-    = let sc = envSysConf env
-      in 
-        proc _
-          -> do siteName    @ (SiteName    _) <- getSysConfA sc -< ()
-                baseURI     @ (BaseURI     _) <- getSysConfA sc -< ()
-                defaultPage @ (DefaultPage _) <- getSysConfA sc -< ()
-                styleSheet  @ (StyleSheet  _) <- getSysConfA sc -< ()
-                languages   @ (Languages   _) <- getSysConfA sc -< ()
-                globalLock  @ (GlobalLock  _) <- getSysConfA sc -< ()
-
-                ( eelem "/"
-                  += ( eelem "systemConfig"
-                       += ( eelem "value"
-                            += sattr "path" (confPath siteName)
-                            += txt (serialize siteName)
-                          )
-                       += ( eelem "value"
-                            += sattr "path" (confPath baseURI)
-                            += txt (serialize baseURI)
-                          )
-                       += ( eelem "value"
-                            += sattr "path" (confPath defaultPage)
-                            += txt (serialize defaultPage)
-                          )
-                       += ( eelem "value"
-                            += sattr "path" (confPath styleSheet)
-                            += txt (serialize styleSheet)
-                          )
-                       += ( eelem "value"
-                            += sattr "path" (confPath languages)
-                            += txt (serialize languages)
-                          )
-                       += ( eelem "value"
-                            += sattr "path" (confPath globalLock)
-                            += txt (serialize globalLock)
-                          )
-                     ) ) -<< ()
+         ( eelem "/"
+           += ( eelem "systemConfig"
+                += ( eelem "value"
+                     += sattr "path" (confPath siteName)
+                     += txt (T.unpack $ serialize siteName)
+                   )
+                += ( eelem "value"
+                     += sattr "path" (confPath baseURI)
+                     += txt (T.unpack $ serialize baseURI)
+                   )
+                += ( eelem "value"
+                     += sattr "path" (confPath defaultPage)
+                     += txt (T.unpack $ serialize defaultPage)
+                   )
+                += ( eelem "value"
+                     += sattr "path" (confPath styleSheet)
+                     += txt (T.unpack $ serialize styleSheet)
+                   )
+                += ( eelem "value"
+                     += sattr "path" (confPath languages)
+                     += txt (T.unpack $ serialize languages)
+                   )
+                += ( eelem "value"
+                     += sattr "path" (confPath globalLock)
+                     += txt (T.unpack $ serialize globalLock)
+                   )
+              ) ) ⤛ ()

 
 

-
-handlePut :: Environment -> Resource ()
-handlePut env
-    = do let sc = envSysConf env
-
-        userID <- getUserID env
-        case userID of
-          Nothing
-              -> setStatus Forbidden
-          Just uid
-              -> runXmlA env "rakka-config-1.0.rng" $ proc tree
-                    -> do listA ( getXPathTreesInDoc "/systemConfig/value"
-                                  >>>
-                                  choiceA [ branch (undefined :: SiteName   )
-                                          , branch (undefined :: BaseURI    )
-                                          , branch (undefined :: DefaultPage)
-                                          , branch (undefined :: StyleSheet )
-                                          , branch (undefined :: Languages  )
-                                          , branch (undefined :: GlobalLock )
-                                          ]
-                                ) -< tree
-                          returnA -< setStatus Ok
-            where
-            branch :: forall a c. (ArrowXml a, ArrowIO a, SysConfValue c) =>
-                      c
-                   -> IfThen (a XmlTree XmlTree) (a XmlTree StatusCode)
-            branch c
-                = hasAttrValue "path" (== confPath c)
-                  :->
-                  ( getChildren
-                    >>> getText
-                    >>> arr (fromJust . (deserialize :: String -> Maybe c))
-                    >>> setSysConfA sc uid )
\ No newline at end of file
+handlePut ∷ Environment → Resource ()
+handlePut env@(Environment {..})
+    = do userID ← getUserID env
+         case userID of
+           Nothing
+               → setStatus Forbidden
+           Just uid
+               → runXmlA "rakka-config-1.0.rng" $ proc tree
+                    → do listA ( getXPathTreesInDoc "/systemConfig/value"
+                                 ⋙
+                                 choiceA [ branch uid ((⊥) ∷ SiteName   )
+                                         , branch uid ((⊥) ∷ BaseURI    )
+                                         , branch uid ((⊥) ∷ DefaultPage)
+                                         , branch uid ((⊥) ∷ StyleSheet )
+                                         , branch uid ((⊥) ∷ Languages  )
+                                         , branch uid ((⊥) ∷ GlobalLock )
+                                         ]
+                               ) ⤙ tree
+                         returnA ⤙ setStatus Ok
+    where
+      branch ∷ ∀(⇝) c. (ArrowXml (⇝), ArrowIO (⇝), SysConfValue c)
+             ⇒ String
+             → c
+             → IfThen (XmlTree ⇝ XmlTree) (XmlTree ⇝ StatusCode)
+      branch uid c
+          = hasAttrValue "path" (≡ confPath c)
+            :->
+            ( getChildren
+              ⋙ getText
+              ⋙ arr (fromJust ∘ (deserialize ∷ Text → Maybe c) ∘ T.pack)
+              ⋙ setSysConfA envSysConf uid )

diff --git a/Rakka/Resource/TrackBack.hs b/Rakka/Resource/TrackBack.hs
index 1bcdbf959156389126454391866ba75be8ac7622..df1f5c3f4e07a13cc114ca2c991d490ea4639660 100644 (file)
--- a/Rakka/Resource/TrackBack.hs
+++ b/Rakka/Resource/TrackBack.hs
@@ -119,7 +119,7 @@ outputResponse res
                                                            , (a_output_encoding, utf8)
                                                            , (a_no_xml_pi      , v_0 ) ]
                                    )
                                                            , (a_output_encoding, utf8)
                                                            , (a_no_xml_pi      , v_0 ) ]
                                    )

-         output xmlStr
+         output $ UTF8.encodeString xmlStr

     where
       mkResponseTree :: ArrowXml a => a b XmlTree
       mkResponseTree 
     where
       mkResponseTree :: ArrowXml a => a b XmlTree
       mkResponseTree 

diff --git a/Rakka/Resource/Users.hs b/Rakka/Resource/Users.hs
index fa61ad86fbe373bf38133dd365a004d6cf4f2f2d..a892c9f914d1811f531dca0dafb3d7151cfad987 100644 (file)
--- a/Rakka/Resource/Users.hs
+++ b/Rakka/Resource/Users.hs
@@ -1,17 +1,28 @@
+{-# LANGUAGE
+    Arrows
+  , DoAndIfThenElse
+  , RecordWildCards
+  , UnicodeSyntax
+  #-}

 module Rakka.Resource.Users
     ( resUsers
     )
     where
 module Rakka.Resource.Users
     ( resUsers
     )
     where

-
-import           Control.Monad
-import           Control.Monad.Trans
-import           Data.Maybe
-import           Network.HTTP.Lucu
-import           Rakka.Authorization
-import           Rakka.Environment
-import           Rakka.Resource
-import           Text.XML.HXT.Arrow hiding (when)
-
+import Control.Arrow
+import Control.Arrow.ArrowList
+import Control.Arrow.Unicode
+import Control.Monad
+import Control.Monad.Trans
+import Data.Maybe
+import Data.Monoid.Unicode
+import Data.Text (Text)
+import qualified Data.Text as T
+import Network.HTTP.Lucu
+import Prelude.Unicode
+import Rakka.Authorization
+import Rakka.Environment
+import Rakka.Resource
+import Text.XML.HXT.Arrow.XmlArrow

 
 resUsers :: Environment -> ResourceDef
 resUsers env
 
 resUsers :: Environment -> ResourceDef
 resUsers env


@@ -40,41 +51,37 @@ resUsers env
   [GET /users/nonexistent]
   404 Not Found
 -}
   [GET /users/nonexistent]
   404 Not Found
 -}

-handleGet :: Environment -> Resource ()
-handleGet env
-    = do userID <- getUserID env
-        when (isNothing userID)
+handleGet ∷ Environment → Resource ()
+handleGet env@(Environment {..})
+    = do userID ← getUserID env
+         when (isNothing userID)

                   $ abort Forbidden [] Nothing
 
                   $ abort Forbidden [] Nothing
 

-        path <- getPathInfo
-        case path of
-          []     -> returnUserList
-          [name] -> returnUser name
-          _      -> foundNoEntity Nothing
+         path ← getPathInfo
+         case path of
+           []     → returnUserList
+           [name] → returnUser (T.pack name)
+           _      → foundNoEntity Nothing

     where
     where

-    returnUserList :: Resource ()
-    returnUserList
-       = do users <- liftIO $ getUserList $ envAuthDB env
-            runIdempotentA' $ proc ()
-                -> do tree <- ( eelem "/"
-                                += ( eelem "users"
-                                     += ( constL users
-                                          >>>
-                                          ( eelem "user"
-                                            += attr "id" mkText
-                                          )
-                                        )
-                                   )
-                              ) -< ()
-                      returnA -< outputXml tree
-
-    returnUser :: String -> Resource ()
-    returnUser name
-       = do users <- liftIO $ getUserList $ envAuthDB env
-            if any (== name) users
-               then setStatus NoContent
-               else foundNoEntity Nothing
-
+      returnUserList ∷ Resource ()
+      returnUserList
+          = do users ← liftIO $ getUserList envAuthDB
+               runIdempotentA' $ proc ()
+                 → do tree ← ( eelem "/"
+                               += ( eelem "users"
+                                    += ( constL users
+                                         ⋙
+                                         ( eelem "user"
+                                           += attr "id" (arr T.unpack ⋙ mkText)
+                                         ) ) ) ) ⤙ ()
+                      returnA ⤙ outputXml tree
+
+      returnUser ∷ Text → Resource ()
+      returnUser name
+          = do users ← liftIO $ getUserList envAuthDB
+               if any (≡ name) users
+               then setStatus NoContent
+               else foundNoEntity Nothing

 
 {-
   > PUT /users/foo HTTP/1.1
 
 {-
   > PUT /users/foo HTTP/1.1


@@ -84,35 +91,34 @@ handleGet env
 
   < HTTP/1.1 201 Created
 -}
 
   < HTTP/1.1 201 Created
 -}

-handlePut :: Environment -> Resource ()
+handlePut ∷ Environment → Resource ()

 handlePut env
 handlePut env

-    = do userID <- getUserID env
-        when (isNothing userID)
-                 $ abort Forbidden [] Nothing
-
-        path <- getPathInfo
-        case path of
-          [name] -> do mimeType <- getContentType
-                       case mimeType of
-                         Nothing
-                             -> abort BadRequest [] (Just "Missing Content-Type")
-                         Just (MIMEType "text" "plain" _)
-                             -> do pass <- input defaultLimit
-                                   addUser (envAuthDB env) name pass
-                         Just t
-                             -> abort UnsupportedMediaType [] (Just $ "Unsupported media type: " ++ show t)
-                        setStatus Created
-          _      -> abort BadRequest [] (Just "Invalid URI")
-
+    = do userID ← getUserID env
+         when (isNothing userID)
+                  $ abort Forbidden [] Nothing

 
 

-handleDelete :: Environment -> Resource ()
+         path ← getPathInfo
+         case path of
+           [name] → do mimeType ← getContentType
+                       case mimeType of
+                         Nothing
+                             → abort BadRequest [] (Just "Missing Content-Type")
+                         Just (MIMEType "text" "plain" _)
+                             → do pass ← input defaultLimit
+                                  addUser (envAuthDB env) (T.pack name) (T.pack pass)
+                         Just t
+                             → abort UnsupportedMediaType [] (Just $ "Unsupported media type: " ⊕ show t)
+                       setStatus Created
+           _      → abort BadRequest [] (Just "Invalid URI")
+
+handleDelete ∷ Environment → Resource ()

 handleDelete env
 handleDelete env

-    = do userID <- getUserID env
+    = do userID ← getUserID env

         when (isNothing userID)
         when (isNothing userID)

-                 $ abort Forbidden [] Nothing
+             $ abort Forbidden [] Nothing

 
 

-        path <- getPathInfo
+        path ← getPathInfo

         case path of
         case path of

-          [name] -> delUser (envAuthDB env) name
-          _      -> abort BadRequest [] (Just "Invalid URI")
+          [name] → delUser (envAuthDB env) (T.pack name)
+          _      → abort BadRequest [] (Just "Invalid URI")

         setStatus NoContent
         setStatus NoContent

diff --git a/Rakka/Storage/DefaultPage.hs b/Rakka/Storage/DefaultPage.hs
index e6f51a55a284dbc8737b3274a00a5acf4501c08f..f9b73f0ca9ee8083360462145bd598a93b4f27c1 100644 (file)
--- a/Rakka/Storage/DefaultPage.hs
+++ b/Rakka/Storage/DefaultPage.hs
@@ -1,48 +1,52 @@
+{-# LANGUAGE
+    Arrows
+  , DoAndIfThenElse
+  , UnicodeSyntax
+  #-}

 module Rakka.Storage.DefaultPage
     ( findAllDefaultPages
     , getDefaultDirContents
     , loadDefaultPage
     )
     where
 module Rakka.Storage.DefaultPage
     ( findAllDefaultPages
     , getDefaultDirContents
     , loadDefaultPage
     )
     where

-
-import           Control.Arrow
-import           Control.Arrow.ArrowIO
-import           Control.Arrow.ArrowList
-import           Data.Set (Set)
-import qualified Data.Set as S
-import           Data.Time.Clock.POSIX
-import           Paths_Rakka -- Cabal が用意する。
-import           Rakka.Page
-import           System.Directory
-import           System.FilePath
-import           System.FilePath.Find hiding (fileName, modificationTime)
-import           System.Posix.Files
-import           Text.XML.HXT.Arrow.ReadDocument
-import           Text.XML.HXT.Arrow.XmlIOStateArrow
-import           Text.XML.HXT.DOM.XmlKeywords
-
-
-doesLocalDirExist :: IO Bool
+import Control.Applicative
+import Control.Arrow
+import Control.Arrow.ArrowIO
+import Control.Arrow.ArrowList
+import Control.Monad.Unicode
+import Data.Set (Set)
+import qualified Data.Set  as S
+import qualified Data.Text as T
+import Data.Time.Clock.POSIX
+import Paths_Rakka
+import Prelude.Unicode
+import Rakka.Page
+import System.Directory
+import System.FilePath
+import System.FilePath.Find hiding (fileName, modificationTime)
+import System.Posix.Files
+import Text.XML.HXT.Arrow.ReadDocument
+import Text.XML.HXT.Arrow.XmlState
+
+doesLocalDirExist ∷ IO Bool

 doesLocalDirExist = doesDirectoryExist "defaultPages"
 
 doesLocalDirExist = doesDirectoryExist "defaultPages"
 

-
-findAllDefaultPages :: IO (Set PageName)
+findAllDefaultPages ∷ IO (Set PageName)

 findAllDefaultPages
 findAllDefaultPages

-    -- ./defaultPages が存在するなら、その中を探す。無ければ Cabal で
-    -- defaultPages を探す。
-    = do localDirExists <- doesLocalDirExist
+    -- If ./defaultPages exists, find pages in it. Otherwise find
+    -- defaultPages using Cabal's Paths_Rakka.
+    = do localDirExists ← doesLocalDirExist

          if localDirExists then
              findAllIn "defaultPages"
          if localDirExists then
              findAllIn "defaultPages"

-           else
-             -- FIXME: この getDataFileName の使ひ方は undocumented
-             findAllIn =<< getDataFileName "defaultPages"
+         else
+             -- FIXME: This usage of getDataFileName is undocumented.
+             findAllIn =≪ getDataFileName "defaultPages"

     where
     where

-      findAllIn :: FilePath -> IO (Set PageName)
+      findAllIn ∷ FilePath → IO (Set PageName)

       findAllIn dirPath
       findAllIn dirPath

-          = find always (fileType ==? RegularFile) dirPath
-            >>=
-            return . S.fromList . map (decodePageName . makeRelative dirPath . dropExtension)
-
+          = (S.fromList ∘ (decodePageName ∘ makeRelative dirPath ∘ dropExtension <$>))
+            <$>
+            find always (fileType ==? RegularFile) dirPath

 
 getDefaultDirContents :: PageName -> IO (Set PageName)
 getDefaultDirContents dir
 
 getDefaultDirContents :: PageName -> IO (Set PageName)
 getDefaultDirContents dir


@@ -66,8 +70,8 @@ getDefaultDirContents dir
                  else
                    return S.empty
 
                  else
                    return S.empty
 

-      m :: FilePath -> FilePath -> PageName
-      m basePath = (dir </>) . decodePageName . makeRelative basePath . dropExtension
+      m ∷ FilePath → FilePath → PageName
+      m basePath = T.pack ∘ (T.unpack dir </>) ∘ T.unpack ∘ decodePageName ∘ makeRelative basePath ∘ dropExtension

 
       f :: FilePath -> Bool
       f "."  = False
 
       f :: FilePath -> Bool
       f "."  = False


@@ -106,27 +110,25 @@ loadPageFile name path
                         )
          return page
 
                         )
          return page
 

-
-loadPageFileA :: IOStateArrow s (PageName, FilePath) Page
+loadPageFileA ∷ IOStateArrow s (PageName, FilePath) Page

 loadPageFileA
 loadPageFileA

-    = proc (name, fpath) ->
-      do tree    <- readFromDocument [ (a_validate         , v_0)
-                                     , (a_check_namespaces , v_1)
-                                     , (a_remove_whitespace, v_1)
-                                     ] -< fpath
-         lastMod <- arrIO (\ x -> getFileStatus x
-                                  >>=
-                                  return . posixSecondsToUTCTime . fromRational . toRational . modificationTime)
-                    -< fpath
-         page    <- parseXmlizedPage -< (name, tree)
-
+    = proc (name, fpath) →
+      do tree    ← readFromDocument [ withValidate        no
+                                    , withCheckNamespaces yes
+                                    , withRemoveWS        yes
+                                    ] ⤙ fpath
+         lastMod ← arrIO ( \x → getFileStatus x
+                                ≫=
+                                pure ∘ posixSecondsToUTCTime ∘ fromRational ∘ toRational ∘ modificationTime
+                         ) ⤙ fpath
+         page    ← parseXmlizedPage ⤙ (name, tree)

          if isEntity page then
          if isEntity page then

-             returnA -< page {
-                           entityRevision = 0
-                         , entityLastMod  = lastMod
-                         }
+             returnA ⤙ page {
+                         entityRevision = 0
+                       , entityLastMod  = lastMod
+                       }

            else
            else

-             returnA -< page {
-                           redirRevision = 0
-                         , redirLastMod  = lastMod
-                         }
+             returnA ⤙ page {
+                         redirRevision = 0
+                       , redirLastMod  = lastMod
+                       }

diff --git a/Rakka/Storage/Impl.hs b/Rakka/Storage/Impl.hs
index bedc9eaa2808d3142e5d4abf91cd00d724369401..8b3cbebcb562fa4ebd7cc6de4967794ce8fb07c4 100644 (file)
--- a/Rakka/Storage/Impl.hs
+++ b/Rakka/Storage/Impl.hs
@@ -1,3 +1,7 @@
+{-# LANGUAGE
+    OverloadedStrings
+  , UnicodeSyntax
+  #-}

 module Rakka.Storage.Impl
     ( getPage'
     , putPage'
 module Rakka.Storage.Impl
     ( getPage'
     , putPage'


@@ -9,19 +13,23 @@ module Rakka.Storage.Impl
     , putAttachment'
     )
     where
     , putAttachment'
     )
     where

-
+import Control.Applicative

 import           Control.Concurrent
 import           Control.Concurrent.STM
 import           Control.Exception
 import           Control.Monad
 import           Data.Maybe
 import           Control.Concurrent
 import           Control.Concurrent.STM
 import           Control.Exception
 import           Control.Monad
 import           Data.Maybe

+import Data.Monoid.Unicode

 import           Data.Set (Set)
 import qualified Data.Set as S
 import           Data.Set (Set)
 import qualified Data.Set as S

+import Data.Text (Text)
+import qualified Data.Text as T

 import           Data.Time
 import           Network.HTTP.Lucu
 import           Network.HTTP.Lucu.Utils
 import           Network.URI
 import           Prelude hiding (words)
 import           Data.Time
 import           Network.HTTP.Lucu
 import           Network.HTTP.Lucu.Utils
 import           Network.URI
 import           Prelude hiding (words)

+import Prelude.Unicode

 import           Rakka.Attachment
 import           Rakka.Page
 import           Rakka.Storage.DefaultPage
 import           Rakka.Attachment
 import           Rakka.Page
 import           Rakka.Storage.DefaultPage


@@ -188,52 +196,51 @@ syncIndex' index revFile repos mkDraft
                mapM_ (updateIndex index repos mkDraft newRev) (S.toList pages)
 
 
                mapM_ (updateIndex index repos mkDraft newRev) (S.toList pages)
 
 

-searchIndex :: Database -> Condition -> IO SearchResult
+searchIndex ∷ Database → Condition → IO SearchResult

 searchIndex index cond
 searchIndex index cond

-    = do (ids, hint) <- searchDatabase' index cond
+    = do (ids, hint) ← searchDatabase' index cond

          let (total, words) = parseHint hint
          let (total, words) = parseHint hint

-         pages <- mapM (fromId words) ids
+         pages ← mapM (fromId words) ids

          return SearchResult {
                       srTotal = total
                     , srPages = pages
                     }
     where
          return SearchResult {
                       srTotal = total
                     , srPages = pages
                     }
     where

-      parseHint :: [(String, Int)] -> (Int, [String])
+      parseHint ∷ [(Text, Int)] → (Int, [Text])

       parseHint xs
           = let total = fromJust $ lookup "" xs
       parseHint xs
           = let total = fromJust $ lookup "" xs

-                words = filter (/= "") $ map fst xs
+                words = filter ((¬) ∘ T.null) $ map fst xs

             in
               (total, words)
 
             in
               (total, words)
 

-      fromId :: [String] -> DocumentID -> IO HitPage
+      fromId ∷ [Text] → DocumentID → IO HitPage

       fromId words docId
       fromId words docId

-          = do uri     <- getDocURI index docId
-               rev     <- unsafeInterleaveIO $
-                          liftM (read . fromJust)
-                                (getDocAttr index docId "rakka:revision")
-               lastMod <- unsafeInterleaveIO $
-                          liftM (zonedTimeToUTC . fromJust . parseW3CDateTime . fromJust)
-                                (getDocAttr index docId "@mdate")
-               summary <- unsafeInterleaveIO $
-                          getDocAttr index docId "rakka:summary"
-               snippet <- unsafeInterleaveIO $
-                          do doc <- getDocument index docId [NoAttributes, NoKeywords]
-                             sn  <- makeSnippet doc words 300 80 80
-                             return (trim (== Boundary) $ map toFragment sn)
-               return HitPage {
-                            hpPageName = decodePageName $ uriPath uri
-                          , hpPageRev  = rev
-                          , hpLastMod  = lastMod
-                          , hpSummary  = summary
-                          , hpSnippet  = snippet
-                          }
-
-      toFragment :: Either String (String, String) -> SnippetFragment
-      toFragment (Left "")      = Boundary
-      toFragment (Left t)       = NormalText t
+          = do uri     ← getDocURI index docId
+               rev     ← unsafeInterleaveIO $
+                         -- FIXME: use Data.Text.Read
+                         read ∘ T.unpack ∘ fromJust
+                         <$> getDocAttr index docId "rakka:revision"
+               lastMod ← unsafeInterleaveIO $
+                         zonedTimeToUTC ∘ fromJust ∘ parseW3CDateTime ∘ T.unpack ∘ fromJust
+                         <$> getDocAttr index docId "@mdate"
+               summary ← unsafeInterleaveIO $
+                         getDocAttr index docId "rakka:summary"
+               snippet ← unsafeInterleaveIO $
+                         do doc ← getDocument index docId [NoAttributes, NoKeywords]
+                            sn  ← makeSnippet doc words 300 80 80
+                            pure (trim (≡ Boundary) $ map toFragment sn)
+               pure HitPage {
+                      hpPageName = decodePageName $ uriPath uri
+                    , hpPageRev  = rev
+                    , hpLastMod  = lastMod
+                    , hpSummary  = summary
+                    , hpSnippet  = snippet
+                    }
+      toFragment ∷ Either Text (Text, Text) -> SnippetFragment
+      toFragment (Left  ""    ) = Boundary
+      toFragment (Left  t     ) = NormalText      t

       toFragment (Right (w, _)) = HighlightedWord w
 
       toFragment (Right (w, _)) = HighlightedWord w
 

-

 updateIndex :: Database
             -> Repository
             -> (Page -> IO Document)
 updateIndex :: Database
             -> Repository
             -> (Page -> IO Document)


@@ -249,11 +256,11 @@ updateIndex index repos mkDraft rev name
                      case docIdM of
                        Nothing    -> return ()
                        Just docId -> do removeDocument index docId [CleaningRemove]
                      case docIdM of
                        Nothing    -> return ()
                        Just docId -> do removeDocument index docId [CleaningRemove]

-                                        infoM logger ("Removed page " ++ name ++ " from the index")
+                                        infoM logger ("Removed page " ⊕ T.unpack name ⊕ " from the index")

            Just page
                -> do draft <- mkDraft page
                      putDocument index draft [CleaningPut]
            Just page
                -> do draft <- mkDraft page
                      putDocument index draft [CleaningPut]

-                     infoM logger ("Indexed page " ++ name ++ " of revision " ++ show (pageRevision page))
+                     infoM logger ("Indexed page " ⊕ T.unpack name ⊕ " of revision " ⊕ show (pageRevision page))

 
 
 updateIndexRev :: FilePath -> (RevNum -> IO RevNum) -> IO ()
 
 
 updateIndexRev :: FilePath -> (RevNum -> IO RevNum) -> IO ()

diff --git a/Rakka/Storage/Repos.hs b/Rakka/Storage/Repos.hs
index a6977e67286e2b35d81ce71e710018616f926fc2..6a90ed6e5365aebd1340cf9a80b11c8e7d0d2582 100644 (file)
--- a/Rakka/Storage/Repos.hs
+++ b/Rakka/Storage/Repos.hs
@@ -1,4 +1,10 @@
 -- -*- coding: utf-8 -*-
 -- -*- coding: utf-8 -*-

+{-# LANGUAGE
+    DoAndIfThenElse
+  , RecordWildCards
+  , ScopedTypeVariables
+  , UnicodeSyntax
+  #-}

 module Rakka.Storage.Repos
     ( findAllPagesInRevision
     , getDirContentsInRevision
 module Rakka.Storage.Repos
     ( findAllPagesInRevision
     , getDirContentsInRevision


@@ -10,16 +16,21 @@ module Rakka.Storage.Repos
     , putAttachmentIntoRepository
     )
     where
     , putAttachmentIntoRepository
     )
     where

-
+import Control.Applicative

 import           Codec.Binary.UTF8.String
 import           Control.Monad
 import           Codec.Binary.UTF8.String
 import           Control.Monad

+import Control.Monad.Unicode
+import qualified Data.CaseInsensitive as CI

 import           Data.List
 import qualified Data.Map as M
 import           Data.Maybe
 import           Data.List
 import qualified Data.Map as M
 import           Data.Maybe

+import Data.Monoid.Unicode

 import           Data.Set (Set)
 import qualified Data.Set as S hiding (Set)
 import           Data.Set (Set)
 import qualified Data.Set as S hiding (Set)

+import qualified Data.Text as T

 import           Data.Time
 import           Network.HTTP.Lucu hiding (redirect)
 import           Data.Time
 import           Network.HTTP.Lucu hiding (redirect)

+import Prelude.Unicode

 import           Rakka.Attachment
 import           Rakka.Page
 import           Rakka.SystemConfig
 import           Rakka.Attachment
 import           Rakka.Page
 import           Rakka.SystemConfig


@@ -85,7 +96,6 @@ findAllPagesInRevision repos rev
       decodePath :: FilePath -> PageName
       decodePath = decodePageName . makeRelative root . dropExtension
 
       decodePath :: FilePath -> PageName
       decodePath = decodePageName . makeRelative root . dropExtension
 

-

 getDirContentsInRevision :: Repository -> PageName -> Maybe RevNum -> IO (Set PageName)
 getDirContentsInRevision repos dir rev
     = do fs   <- getRepositoryFS repos
 getDirContentsInRevision :: Repository -> PageName -> Maybe RevNum -> IO (Set PageName)
 getDirContentsInRevision repos dir rev
     = do fs   <- getRepositoryFS repos


@@ -105,9 +115,8 @@ getDirContentsInRevision repos dir rev
       getDir' :: Rev [PageName]
       getDir' = liftM (map entToName) (getDirEntries path)
 
       getDir' :: Rev [PageName]
       getDir' = liftM (map entToName) (getDirEntries path)
 

-      entToName :: DirEntry -> PageName
-      entToName = (dir </>) . decodePageName . dropExtension . entName
-
+      entToName ∷ DirEntry → PageName
+      entToName = T.pack ∘ (T.unpack dir </>) ∘ T.unpack ∘ decodePageName ∘ dropExtension ∘ entName

 
 findChangedPagesAtRevision :: Repository -> RevNum -> IO (Set PageName)
 findChangedPagesAtRevision repos rev
 
 findChangedPagesAtRevision :: Repository -> RevNum -> IO (Set PageName)
 findChangedPagesAtRevision repos rev


@@ -169,7 +178,7 @@ loadPageInRepository repos name rev
                return Entity {
                             entityName       = name
                           , entityType       = mimeType
                return Entity {
                             entityName       = name
                           , entityType       = mimeType

-                          , entityLanguage   = fmap chomp (lookup "rakka:lang" props)
+                          , entityLanguage   = CI.mk ∘ T.pack ∘ chomp <$> lookup "rakka:lang" props

                           , entityIsTheme    = any ((== "rakka:isTheme") . fst) props
                           , entityIsFeed     = any ((== "rakka:isFeed") . fst) props
                           , entityIsLocked   = any ((== "rakka:isLocked") . fst) props
                           , entityIsTheme    = any ((== "rakka:isTheme") . fst) props
                           , entityIsFeed     = any ((== "rakka:isFeed") . fst) props
                           , entityIsLocked   = any ((== "rakka:isLocked") . fst) props


@@ -181,11 +190,10 @@ loadPageInRepository repos name rev
                           , entityRevision   = pageRev
                           , entityLastMod    = zonedTimeToUTC lastMod
                           , entitySummary    = fmap decodeString (lookup "rakka:summary" props)
                           , entityRevision   = pageRev
                           , entityLastMod    = zonedTimeToUTC lastMod
                           , entitySummary    = fmap decodeString (lookup "rakka:summary" props)

-                          , entityOtherLang  = fromMaybe M.empty
-                                             $ fmap
-                                                   (M.fromList . fromJust . deserializeStringPairs . decodeString)
-                                                   (lookup "rakka:otherLang" props)
-                          , entityContent    = content                                             
+                          , entityOtherLang  = maybe (∅)
+                                                     (fromJust ∘ deserializeMap CI.mk id ∘ T.pack ∘ decodeString)
+                                                     (lookup "rakka:otherLang" props)
+                          , entityContent    = content

                           , entityUpdateInfo = undefined
                           }
       
                           , entityUpdateInfo = undefined
                           }
       


@@ -195,7 +203,7 @@ loadPageInRepository repos name rev
                content <- getFileContents path
 
                let pageRev = fst $ head hist
                content <- getFileContents path
 
                let pageRev = fst $ head hist

-                   dest    = chomp $ decodeString content
+                   dest    = T.pack ∘ chomp $ decodeString content

 
                lastMod <- unsafeIOToFS $
                           liftM (fromJust . parseW3CDateTime . chomp . fromJust)
 
                lastMod <- unsafeIOToFS $
                           liftM (fromJust . parseW3CDateTime . chomp . fromJust)


@@ -213,63 +221,64 @@ loadPageInRepository repos name rev
                           }
 
 
                           }
 
 

-putPageIntoRepository :: Repository -> Maybe String -> Page -> IO StatusCode
+putPageIntoRepository ∷ Repository → Maybe String → Page → IO StatusCode

 putPageIntoRepository repos userID page
 putPageIntoRepository repos userID page

-    = do let name   = pageName page
-             author = fromMaybe "[Rakka]" userID
-         case pageUpdateInfo page of
-           Just ui
-               -> do let oldRev = uiOldRevision ui
-                     denied <- case uiOldName ui of
-                                 Nothing      -> checkDenial oldRev name
-                                 Just oldName -> checkDenial oldRev oldName
-                     if denied then
-                         return Forbidden
-                       else
-                         do rev <- if oldRev == 0 then
-                                       getRepositoryFS repos >>= getYoungestRev
-                                   else
-                                       return oldRev
-                            ret <- doReposTxn
-                                   repos
-                                   rev
-                                   author
-                                   (Just "Automatic commit by Rakka for page update")
-                                   $ do 
-                                        case uiOldName ui of
-                                          Nothing      -> return ()
-                                          Just oldName -> do exists <- isFile (mkPagePath oldName)
-                                                             when exists
-                                                                  $ do movePage (uiOldRevision ui) oldName name
-                                                                       moveAttachments (uiOldRevision ui) oldName name
-                                        exists <- isFile (mkPagePath name)
-                                        unless exists
-                                               $ createPage name
-                                        updatePage name
-                            case ret of
-                              Left  _ -> return Conflict
-                              Right _ -> return Created
-           Nothing
-               -> do fs  <- getRepositoryFS repos
-                     rev <- getYoungestRev fs
-                     ret <- doReposTxn
-                            repos
-                            rev
-                            author
-                            (Just "Automatic commit by Rakka for page creation")
-                            $ do createPage name
-                                 updatePage name
-                     case ret of
-                       Left  _ -> return Conflict
-                       Right _ -> return Created
+    = case pageUpdateInfo page of
+        Just ui
+            → do let oldRev = uiOldRevision ui
+                 denied ← case uiOldName ui of
+                            Nothing      → shouldDeny oldRev name
+                            Just oldName → shouldDeny oldRev oldName
+                 if denied then
+                     pure Forbidden
+                 else
+                     do rev ← if oldRev ≡ 0 then
+                                  getRepositoryFS repos ≫= getYoungestRev
+                              else
+                                  return oldRev
+                        ret ← doReposTxn repos
+                                         rev
+                                         author
+                                         (Just "Automatic commit by Rakka for page update")
+                              $ do case uiOldName ui of
+                                     Nothing      → return ()
+                                     Just oldName → do exists ← isFile (mkPagePath oldName)
+                                                       when exists
+                                                           ( movePage        (uiOldRevision ui) oldName name ≫
+                                                             moveAttachments (uiOldRevision ui) oldName name
+                                                           )
+                                   exists ← isFile (mkPagePath name)
+                                   unless exists
+                                       $ createPage name
+                                   updatePage name
+                        case ret of
+                          Left  _ → return Conflict
+                          Right _ → return Created
+        Nothing
+            → do fs  ← getRepositoryFS repos
+                 rev ← getYoungestRev fs
+                 ret ← doReposTxn repos
+                                  rev
+                                  author
+                                  (Just "Automatic commit by Rakka for page creation")
+                       $ (createPage name ≫ updatePage name)
+                 case ret of
+                   Left  _ → return Conflict
+                   Right _ → return Created

     where
     where

-      checkDenial :: RevNum -> PageName -> IO Bool
-      checkDenial rev name
-          = do fs <- getRepositoryFS repos
+      name ∷ PageName
+      name = pageName page
+
+      author ∷ String
+      author = fromMaybe "[Rakka]" userID
+
+      shouldDeny ∷ RevNum → PageName → IO Bool
+      shouldDeny rev name'
+          = do fs ← getRepositoryFS repos

                withRevision fs rev
                withRevision fs rev

-                   $ do exists <- isFile (mkPagePath name)
+                   $ do exists ← isFile (mkPagePath name')

                         if exists then
                         if exists then

-                            do prop <- getNodeProp (mkPagePath name) "rakka:isLocked"
+                            do prop ← getNodeProp (mkPagePath name') "rakka:isLocked"

                                case prop of
                                  Just _  -> return (isNothing userID) -- 施錠されてゐるので匿名では駄目
                                  Nothing -> return False
                                case prop of
                                  Just _  -> return (isNothing userID) -- 施錠されてゐるので匿名では駄目
                                  Nothing -> return False


@@ -295,20 +304,20 @@ putPageIntoRepository repos userID page
                deleteEmptyParentDirectories oldPath
 
       createPage :: PageName -> Txn ()
                deleteEmptyParentDirectories oldPath
 
       createPage :: PageName -> Txn ()

-      createPage name
-          = do let path = mkPagePath name
+      createPage name'
+          = do let path = mkPagePath name'

                createParentDirectories path
                makeFile path
 
                createParentDirectories path
                makeFile path
 

-      updatePage :: PageName -> Txn ()
-      updatePage name
-          | isRedirect page = updatePageRedirect name
-          | isEntity   page = updatePageEntity name
+      updatePage ∷ PageName → Txn ()
+      updatePage name'
+          | isRedirect page = updatePageRedirect name'
+          | isEntity   page = updatePageEntity   name'

           | otherwise       = fail "neither redirection nor page"
 
       updatePageRedirect :: PageName -> Txn ()
           | otherwise       = fail "neither redirection nor page"
 
       updatePageRedirect :: PageName -> Txn ()

-      updatePageRedirect name
-          = do let path = mkPagePath name
+      updatePageRedirect name'
+          = do let path = mkPagePath name'

                setNodeProp path "svn:mime-type"   (Just "application/x-rakka-redirection")
                setNodeProp path "rakka:lang"      Nothing
                setNodeProp path "rakka:isTheme"   Nothing
                setNodeProp path "svn:mime-type"   (Just "application/x-rakka-redirection")
                setNodeProp path "rakka:lang"      Nothing
                setNodeProp path "rakka:isTheme"   Nothing


@@ -317,24 +326,24 @@ putPageIntoRepository repos userID page
                setNodeProp path "rakka:isBinary"  Nothing
                setNodeProp path "rakka:summary"   Nothing
                setNodeProp path "rakka:otherLang" Nothing
                setNodeProp path "rakka:isBinary"  Nothing
                setNodeProp path "rakka:summary"   Nothing
                setNodeProp path "rakka:otherLang" Nothing

-               applyText path Nothing (encodeString (redirDest page) ++ "\n")
+               applyText path Nothing (encodeString (T.unpack $ redirDest page) ⊕ "\n")

 
       updatePageEntity :: PageName -> Txn ()
 
       updatePageEntity :: PageName -> Txn ()

-      updatePageEntity name
-          = do let path = mkPagePath name
-               setNodeProp path "svn:mime-type"   ((Just . show . entityType) page)
-               setNodeProp path "rakka:lang"      (entityLanguage page)
-               setNodeProp path "rakka:isTheme"   (encodeFlag $ entityIsTheme page)
-               setNodeProp path "rakka:isFeed"    (encodeFlag $ entityIsFeed page)
+      updatePageEntity name'
+          = do let path = mkPagePath name'
+               setNodeProp path "svn:mime-type"   (Just ∘ show $ entityType page)
+               setNodeProp path "rakka:lang"      (T.unpack ∘ CI.foldedCase <$> entityLanguage page)
+               setNodeProp path "rakka:isTheme"   (encodeFlag $ entityIsTheme  page)
+               setNodeProp path "rakka:isFeed"    (encodeFlag $ entityIsFeed   page)

                setNodeProp path "rakka:isLocked"  (encodeFlag $ entityIsLocked page)
                setNodeProp path "rakka:isBinary"  (encodeFlag $ entityIsBinary page)
                setNodeProp path "rakka:isLocked"  (encodeFlag $ entityIsLocked page)
                setNodeProp path "rakka:isBinary"  (encodeFlag $ entityIsBinary page)

-               setNodeProp path "rakka:summary"   (fmap encodeString $ entitySummary page)
-               setNodeProp path "rakka:otherLang" (let otherLang = entityOtherLang page
-                                                   in
-                                                     if M.null otherLang then
-                                                         Nothing
-                                                     else
-                                                         Just (encodeString $ serializeStringPairs $ M.toList otherLang))
+               setNodeProp path "rakka:summary"   (encodeString <$> entitySummary page)
+               setNodeProp path "rakka:otherLang" ( if M.null (entityOtherLang page) then
+                                                        Nothing
+                                                    else
+                                                        Just ∘ T.unpack ∘ serializeMap CI.foldedCase id
+                                                        $ entityOtherLang page
+                                                  )

                applyTextLBS path Nothing (entityContent page)
 
       encodeFlag :: Bool -> Maybe String
                applyTextLBS path Nothing (entityContent page)
 
       encodeFlag :: Bool -> Maybe String


@@ -399,12 +408,12 @@ deleteEmptyParentDirectories path
                        deleteEmptyParentDirectories parentPath
 
 
                        deleteEmptyParentDirectories parentPath
 
 

-loadAttachmentInRepository :: forall a. Attachment a =>
-                              Repository
-                           -> PageName
-                           -> String
-                           -> Maybe RevNum
-                           -> IO (Maybe a)
+loadAttachmentInRepository ∷ ∀α. Attachment α
+                           ⇒ Repository
+                           → PageName
+                           → String
+                           → Maybe RevNum
+                           → IO (Maybe α)

 loadAttachmentInRepository repos pName aName rev
     = do fs   <- getRepositoryFS repos
          rev' <- case rev of
 loadAttachmentInRepository repos pName aName rev
     = do fs   <- getRepositoryFS repos
          rev' <- case rev of


@@ -417,12 +426,12 @@ loadAttachmentInRepository repos pName aName rev
                     else
                       return Nothing
     where
                     else
                       return Nothing
     where

-      path :: FilePath
+      path ∷ FilePath

       path = mkAttachmentPath pName aName
 
       path = mkAttachmentPath pName aName
 

-      loadAttachment' :: Rev a
-      loadAttachment' = liftM (deserializeFromString . decodeString) (getFileContents path)
-
+      loadAttachment' ∷ Rev α
+      loadAttachment' = (deserializeFromString ∘ decodeString)
+                        `liftM` getFileContents path

 
 putAttachmentIntoRepository :: Attachment a =>
                                Repository
 
 putAttachmentIntoRepository :: Attachment a =>
                                Repository

diff --git a/Rakka/Storage/Types.hs b/Rakka/Storage/Types.hs
index e9b848ba8cdab1527fba5db257c9ceed764288d5..75d8ef158ba8c76481ae96efc8ef01166d84a311 100644 (file)
--- a/Rakka/Storage/Types.hs
+++ b/Rakka/Storage/Types.hs
@@ -1,3 +1,6 @@
+{-# LANGUAGE
+    UnicodeSyntax
+  #-}

 module Rakka.Storage.Types
     ( Storage(..)
     , IndexReq(..)
 module Rakka.Storage.Types
     ( Storage(..)
     , IndexReq(..)


@@ -6,14 +9,13 @@ module Rakka.Storage.Types
     , SnippetFragment(..)
     )
     where
     , SnippetFragment(..)
     )
     where

-
-import           Control.Concurrent.STM
-import           Data.Time
-import           Rakka.Page
-import           Subversion.Repository
-import           Subversion.Types
-import           Text.HyperEstraier hiding (WriteLock)
-
+import Control.Concurrent.STM
+import Data.Text (Text)
+import Data.Time
+import Rakka.Page
+import Subversion.Repository
+import Subversion.Types
+import Text.HyperEstraier hiding (WriteLock)

 
 data Storage
     = Storage {
 
 data Storage
     = Storage {


@@ -21,13 +23,11 @@ data Storage
       , stoIndexChan  :: !(TChan IndexReq)
       }
 
       , stoIndexChan  :: !(TChan IndexReq)
       }
 

-

 data IndexReq
     = RebuildIndex
     | SyncIndex
     | SearchIndex !Condition !(TMVar SearchResult)
 
 data IndexReq
     = RebuildIndex
     | SyncIndex
     | SearchIndex !Condition !(TMVar SearchResult)
 

-

 data SearchResult
     = SearchResult {
         srTotal :: !Int
 data SearchResult
     = SearchResult {
         srTotal :: !Int


@@ -35,20 +35,18 @@ data SearchResult
       }
     deriving (Show, Eq)
 
       }
     deriving (Show, Eq)
 

-

 data HitPage
     = HitPage {
         hpPageName :: !PageName
       , hpPageRev  :: RevNum
       , hpLastMod  :: UTCTime
 data HitPage
     = HitPage {
         hpPageName :: !PageName
       , hpPageRev  :: RevNum
       , hpLastMod  :: UTCTime

-      , hpSummary  :: Maybe String
+      , hpSummary  :: Maybe Text

       , hpSnippet  :: [SnippetFragment]
       }
     deriving (Show, Eq)
 
       , hpSnippet  :: [SnippetFragment]
       }
     deriving (Show, Eq)
 

-

 data SnippetFragment
     = Boundary
 data SnippetFragment
     = Boundary

-    | NormalText      !String
-    | HighlightedWord !String
-    deriving (Show, Eq)
\ No newline at end of file
+    | NormalText      !Text
+    | HighlightedWord !Text
+    deriving (Show, Eq)

diff --git a/Rakka/SystemConfig.hs b/Rakka/SystemConfig.hs
index aa1e5798d24ee387bac9582797fc97d492d79a17..029d307ca2757560c413fd024e5ad1b348a82ad9 100644 (file)
--- a/Rakka/SystemConfig.hs
+++ b/Rakka/SystemConfig.hs
@@ -1,3 +1,9 @@
+{-# LANGUAGE
+    DeriveDataTypeable
+  , OverloadedStrings
+  , ScopedTypeVariables
+  , UnicodeSyntax
+  #-}

 module Rakka.SystemConfig
     ( SystemConfig
     , SysConfValue(..)
 module Rakka.SystemConfig
     ( SystemConfig
     , SysConfValue(..)


@@ -17,28 +23,37 @@ module Rakka.SystemConfig
     , Languages(..)
     , GlobalLock(..)
 
     , Languages(..)
     , GlobalLock(..)
 

-    , serializeStringPairs
-    , deserializeStringPairs
+    , serializeTextPairs
+    , deserializeTextPairs
+    , serializeMap
+    , deserializeMap

     )
     where
     )
     where

-
+import Control.Applicative

 import           Codec.Binary.UTF8.String
 import           Control.Arrow.ArrowIO
 import           Codec.Binary.UTF8.String
 import           Control.Arrow.ArrowIO

+import Control.Arrow.Unicode

 import           Control.Concurrent.STM
 import           Control.Monad
 import           Control.Monad.Trans
 import           Control.Concurrent.STM
 import           Control.Monad
 import           Control.Monad.Trans

+import Control.Monad.Unicode

 import qualified Data.ByteString.Char8 as C8
 import qualified Data.ByteString.Lazy  as L
 import qualified Data.ByteString.Char8 as C8
 import qualified Data.ByteString.Lazy  as L

+import qualified Data.CaseInsensitive as CI

 import           Data.Dynamic
 import           Data.Map (Map)
 import qualified Data.Map as M
 import           Data.Maybe
 import           Data.Dynamic
 import           Data.Map (Map)
 import qualified Data.Map as M
 import           Data.Maybe

+import Data.Monoid.Unicode
+import Data.Text (Text)
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as T

 import           GHC.Conc (unsafeIOToSTM)
 import           GHC.Conc (unsafeIOToSTM)

-import           Network
+import           Network.BSD

 import qualified Network.HTTP.Lucu.Config as LC
 import qualified Network.HTTP.Lucu.Config as LC

-import           Network.HTTP.Lucu.Utils

 import           Network.HTTP.Lucu hiding (Config)
 import           Network.URI hiding (path)
 import           Network.HTTP.Lucu hiding (Config)
 import           Network.URI hiding (path)

+import Prelude.Unicode

 import           Rakka.Page
 import           Rakka.Utils
 import           Subversion.FileSystem
 import           Rakka.Page
 import           Rakka.Utils
 import           Subversion.FileSystem


@@ -48,9 +63,9 @@ import           Subversion.FileSystem.Transaction
 import           Subversion.Repository
 import           Subversion.Types
 import           System.FilePath.Posix
 import           Subversion.Repository
 import           Subversion.Types
 import           System.FilePath.Posix

+import System.IO.Unsafe

 import           System.Log.Logger
 
 import           System.Log.Logger
 

-

 logger :: String
 logger = "Rakka.SystemConfig"
 
 logger :: String
 logger = "Rakka.SystemConfig"
 


@@ -61,13 +76,11 @@ data SystemConfig = SystemConfig {
     , scCache      :: !(TVar (Map FilePath Dynamic))
     }
 
     , scCache      :: !(TVar (Map FilePath Dynamic))
     }
 

-
-class (Typeable a, Show a, Eq a) => SysConfValue a where
-    confPath     :: a -> FilePath
-    serialize    :: a -> String
-    deserialize  :: String -> Maybe a
-    defaultValue :: SystemConfig -> a
-
+class (Typeable α, Show α, Eq α) ⇒ SysConfValue α where
+    confPath     ∷ α → FilePath
+    serialize    ∷ α → Text
+    deserialize  ∷ Text → Maybe α
+    defaultValue ∷ SystemConfig → α

 
 mkSystemConfig :: LC.Config -> Repository -> IO SystemConfig
 mkSystemConfig lc repos
 
 mkSystemConfig :: LC.Config -> Repository -> IO SystemConfig
 mkSystemConfig lc repos


@@ -78,49 +91,42 @@ mkSystemConfig lc repos
                     , scCache      = cache
                     }
 
                     , scCache      = cache
                     }
 

-getSysConf :: forall m a. (MonadIO m, SysConfValue a) => SystemConfig -> m a
+getSysConf ∷ ∀m a. (MonadIO m, SysConfValue a) ⇒ SystemConfig → m a

 getSysConf sc
 getSysConf sc

-    = liftIO $
-      atomically $
-      do let path = confPath (undefined :: a)
-
-         cache <- readTVar (scCache sc)
-
+    = liftIO $ atomically $
+      do cache ← readTVar (scCache sc)
+         let path = confPath ((⊥) ∷ a)

          case M.lookup path cache of
          case M.lookup path cache of

-           Just val -> return $ fromJust $ fromDynamic val
-           Nothing  -> do val <- unsafeIOToSTM (getSysConf' sc)
-                          writeTVar (scCache sc) (M.insert path (toDyn val) cache)
-                          return val
+           Just val → pure ∘ fromJust $ fromDynamic val
+           Nothing  → do val ← unsafeIOToSTM (getSysConf' sc)
+                         writeTVar (scCache sc) (M.insert path (toDyn val) cache)
+                         return val

 
 

-
-getSysConf' :: forall a. SysConfValue a => SystemConfig -> IO a
+getSysConf' ∷ ∀α. SysConfValue α ⇒ SystemConfig → IO α

 getSysConf' sc
 getSysConf' sc

-    = do let path = fromConfPath $ confPath (undefined :: a)
-
-         fs    <- getRepositoryFS (scRepository sc)
-         rev   <- getYoungestRev fs
-         value <- withRevision fs rev
-                  $ do exists <- isFile path
-                       case exists of
-                         True
-                             -> do str <- getFileContentsLBS path
-                                   return $ Just $ chomp $ decode $ L.unpack str
-                         False
-                             -> return Nothing
-
+    = do let path = fromConfPath $ confPath ((⊥) ∷ α)
+         fs    ← getRepositoryFS (scRepository sc)
+         rev   ← getYoungestRev fs
+         value ← withRevision fs rev
+                 $ do exists ← isFile path
+                      case exists of
+                        True
+                            → do str ← getFileContentsLBS path
+                                 return $ Just $ T.pack $ chomp $ decode $ L.unpack str
+                        False
+                            → return Nothing

          case value of
            Just str
          case value of
            Just str

-               -> case deserialize str of
-                    Just val
-                        -> do debugM logger ("Got a config value at `" ++ path ++ "': " ++ show val)
-                              return val
-                    Nothing
-                        -> fail ("Got an invalid config value at `" ++ path ++ "': " ++ str)
+               → case deserialize str of
+                   Just val
+                       → debugM logger ("Got a config value at `" ⊕ path ⊕ "': " ⊕ show val) ≫
+                         return val
+                   Nothing
+                       → fail ("Got an invalid config value at `" ⊕ path ⊕ "': " ⊕ show str)

            Nothing
            Nothing

-               -> do let val = defaultValue sc
-                     debugM logger ("Got no config value at `" ++ path ++ "'. Defaulting to " ++ show val)
-                     return val
-
+               → do let val = defaultValue sc
+                    debugM logger ("Got no config value at `" ⊕ path ⊕ "'. Defaulting to " ⊕ show val)
+                    return val

 
 setSysConf :: forall m a. (MonadIO m, SysConfValue a) => SystemConfig -> String -> a -> m StatusCode
 setSysConf sc userID value
 
 setSysConf :: forall m a. (MonadIO m, SysConfValue a) => SystemConfig -> String -> a -> m StatusCode
 setSysConf sc userID value


@@ -135,42 +141,41 @@ setSysConf sc userID value
                    setSysConf' sc userID value
 
 
                    setSysConf' sc userID value
 
 

-setSysConf' :: forall a. SysConfValue a => SystemConfig -> String -> a -> IO StatusCode
+setSysConf' ∷ ∀α. SysConfValue α ⇒ SystemConfig → String → α → IO StatusCode

 setSysConf' sc userID value
 setSysConf' sc userID value

-    = do let path  = fromConfPath $ confPath (undefined :: a)
-            str   = L.pack $ encode $ serialize value ++ "\n"
+    = do let path  = fromConfPath $ confPath ((⊥) ∷ α)
+            str   = (L.fromChunks ∘ (:[]) ∘ T.encodeUtf8 $ serialize value) ⊕ "\n"

             repos = scRepository sc
             repos = scRepository sc

-         fs  <- getRepositoryFS repos
-        rev <- getYoungestRev fs
-        ret <- doReposTxn
-               repos
-               rev
-               userID
-               (Just "Automatic commit by Rakka for systemConfig update")
-               $ do exists <- isFile path
-                    unless exists
-                        $ createValueEntry path
-                    applyTextLBS path Nothing str
+         fs  ← getRepositoryFS repos
+        rev ← getYoungestRev fs
+         ret ← doReposTxn
+               repos
+               rev
+               userID
+               (Just "Automatic commit by Rakka for systemConfig update")
+               $ do exists ← isFile path
+                    unless exists
+                        $ createValueEntry path
+                    applyTextLBS path Nothing str

         case ret of
         case ret of

-                 Left  _ -> return Conflict
-                 Right _ -> do debugM logger ("Set a config value at `" ++ path ++ "': " ++ show value)
-                               return Created
+          Left  _ → return Conflict
+          Right _ → do debugM logger ("Set a config value at `" ⊕ path ⊕ "': " ⊕ show value)
+                        return Created

     where
     where

-    createValueEntry :: FilePath -> Txn ()
+    createValueEntry ∷ FilePath → Txn ()

     createValueEntry path
     createValueEntry path

-       = do createParentDirectories path
-            makeFile path
+        = do createParentDirectories path
+             makeFile path

 
 

-    createParentDirectories :: FilePath -> Txn ()
+    createParentDirectories ∷ FilePath → Txn ()

     createParentDirectories path
     createParentDirectories path

-       = do let parentPath = takeDirectory path
-            kind <- checkPath parentPath
-            case kind of
-                      NoNode   -> do createParentDirectories parentPath
-                                     makeDirectory parentPath
-                      FileNode -> fail ("createParentDirectories: already exists a file: " ++ parentPath)
-                      DirNode  -> return ()
-
+        = do let parentPath = takeDirectory path
+             kind ← checkPath parentPath
+             case kind of
+               NoNode   → createParentDirectories parentPath ≫
+                          makeDirectory parentPath
+               FileNode → fail ("createParentDirectories: already exists a file: " ⊕ parentPath)
+               DirNode  → return ()

 
 getSysConfA :: (ArrowIO a, SysConfValue c) => SystemConfig -> a b c
 getSysConfA = arrIO0 . getSysConf
 
 getSysConfA :: (ArrowIO a, SysConfValue c) => SystemConfig -> a b c
 getSysConfA = arrIO0 . getSysConf


@@ -183,51 +188,49 @@ setSysConfA = (arrIO .) . setSysConf
 fromConfPath :: FilePath -> FilePath
 fromConfPath = ("/config" </>)
 
 fromConfPath :: FilePath -> FilePath
 fromConfPath = ("/config" </>)
 

-
-serializeStringPairs :: [(String, String)] -> String
-serializeStringPairs = joinWith "\n" . map serializePair'
+serializeTextPairs ∷ [(Text, Text)] → Text
+serializeTextPairs = T.intercalate "\n" ∘ (serializePair' <$>)

     where
     where

-      serializePair' :: (String, String) -> String
-      serializePair' (a, b) = a ++ " " ++ b
+      serializePair' ∷ (Text, Text) → Text
+      serializePair' (a, b) = a ⊕ " " ⊕ b

 
 

+serializeMap ∷ (k → Text) → (v → Text) → Map k v → Text
+serializeMap f g = serializeTextPairs ∘ ((f ⁂ g) <$>) ∘ M.toList

 
 

-deserializeStringPairs :: String -> Maybe [(String, String)]
-deserializeStringPairs = mapM deserializePair' . lines
+deserializeTextPairs ∷ Text → Maybe [(Text, Text)]
+deserializeTextPairs = mapM deserializePair' ∘ T.lines

     where
     where

-      deserializePair' :: String -> Maybe (String, String)
-      deserializePair' s = case break (== ' ') s of
-                             (a, ' ':b) -> Just (a, b)
-                             _          -> Nothing
-
-
+      deserializePair' ∷ Text → Maybe (Text, Text)
+      deserializePair' s = case T.breakOn " " s of
+                             (a, b)
+                                 | (¬) (T.null b) → Just (a, T.tail b)
+                             _                    → Nothing

 
 

-{- config values -}
+deserializeMap ∷ Ord k ⇒ (Text → k) → (Text → v) → Text → Maybe (Map k v)
+deserializeMap f g = (M.fromList ∘ ((f ⁂ g) <$>) <$>) ∘ deserializeTextPairs

 
 

-newtype SiteName = SiteName String deriving (Show, Typeable, Eq)
+newtype SiteName = SiteName Text deriving (Show, Typeable, Eq)

 instance SysConfValue SiteName where
     confPath _                = "siteName"
     serialize (SiteName name) = name
     deserialize               = Just . SiteName
     defaultValue _            = SiteName "Rakka"
 
 instance SysConfValue SiteName where
     confPath _                = "siteName"
     serialize (SiteName name) = name
     deserialize               = Just . SiteName
     defaultValue _            = SiteName "Rakka"
 

-

 newtype BaseURI = BaseURI URI deriving (Show, Typeable, Eq)
 instance SysConfValue BaseURI where
     confPath _              = "baseURI"
 newtype BaseURI = BaseURI URI deriving (Show, Typeable, Eq)
 instance SysConfValue BaseURI where
     confPath _              = "baseURI"

-    serialize (BaseURI uri) = uriToString id uri ""
+    serialize (BaseURI uri) = T.pack $ uriToString id uri ""

     deserialize uri         = fmap BaseURI
     deserialize uri         = fmap BaseURI

-                              $ do parsed <- parseURI uri
-                                   when (uriPath parsed        == "" ) (fail undefined)
-                                   when (last (uriPath parsed) /= '/') (fail undefined)
-                                   when (uriQuery parsed       /= "" ) (fail undefined)
-                                   when (uriFragment parsed    /= "" ) (fail undefined)
+                              $ do parsed ← parseURI (T.unpack uri)
+                                   when (uriPath parsed        ≡ "" ) mzero
+                                   when (last (uriPath parsed) ≠ '/') mzero
+                                   when (uriQuery parsed       ≠ "" ) mzero
+                                   when (uriFragment parsed    ≠ "" ) mzero

                                    return parsed
     defaultValue sc
         = let conf = scLucuConf sc
               host = C8.unpack $ LC.cnfServerHost conf
                                    return parsed
     defaultValue sc
         = let conf = scLucuConf sc
               host = C8.unpack $ LC.cnfServerHost conf

-              port = case LC.cnfServerPort conf of
-                       PortNumber num -> fromIntegral num :: Int
-                       _              -> undefined
+              port = unsafePerformIO ∘ getServicePortNumber $ LC.cnfServerPort conf

               defaultURI
                   = "http://" ++ host ++ -- FIXME: consider IPv6 address
                     (if port == 80
               defaultURI
                   = "http://" ++ host ++ -- FIXME: consider IPv6 address
                     (if port == 80


@@ -236,28 +239,25 @@ instance SysConfValue BaseURI where
           in
             BaseURI $ fromJust $ parseURI defaultURI
 
           in
             BaseURI $ fromJust $ parseURI defaultURI
 

-
-newtype DefaultPage = DefaultPage String deriving (Show, Typeable, Eq)
+newtype DefaultPage = DefaultPage Text deriving (Show, Typeable, Eq)

 instance SysConfValue DefaultPage where
     confPath _                   = "defaultPage"
     serialize (DefaultPage name) = name
     deserialize                  = Just . DefaultPage
     defaultValue _               = DefaultPage "MainPage"
 
 instance SysConfValue DefaultPage where
     confPath _                   = "defaultPage"
     serialize (DefaultPage name) = name
     deserialize                  = Just . DefaultPage
     defaultValue _               = DefaultPage "MainPage"
 

-
-newtype StyleSheet = StyleSheet String deriving (Show, Typeable, Eq)
+newtype StyleSheet = StyleSheet Text deriving (Show, Typeable, Eq)

 instance SysConfValue StyleSheet where
     confPath _                  = "styleSheet"
     serialize (StyleSheet name) = name
     deserialize                 = Just . StyleSheet
     defaultValue _              = StyleSheet "StyleSheet/Default"
 
 instance SysConfValue StyleSheet where
     confPath _                  = "styleSheet"
     serialize (StyleSheet name) = name
     deserialize                 = Just . StyleSheet
     defaultValue _              = StyleSheet "StyleSheet/Default"
 

-

 newtype Languages = Languages (Map LanguageTag LanguageName) deriving (Show, Typeable, Eq)
 instance SysConfValue Languages where
     confPath _                  = "languages"
 newtype Languages = Languages (Map LanguageTag LanguageName) deriving (Show, Typeable, Eq)
 instance SysConfValue Languages where
     confPath _                  = "languages"

-    serialize (Languages langs) = serializeStringPairs (M.toList langs)
-    deserialize                 = fmap (Languages . M.fromList) . deserializeStringPairs
+    serialize (Languages langs) = serializeMap CI.foldedCase id langs
+    deserialize                 = (Languages <$>) ∘ deserializeMap CI.mk id

     defaultValue _         
         = Languages $ M.fromList [ ("en", "English"  )
                                  , ("es", "Español"  )
     defaultValue _         
         = Languages $ M.fromList [ ("en", "English"  )
                                  , ("es", "Español"  )

diff --git a/Rakka/Utils.hs b/Rakka/Utils.hs
index 15bc6f4043f5a87f149cd09a5147c4cb4cb5be7c..3148c6bf108906112b39ebb81f63132ae8baa158 100644 (file)
--- a/Rakka/Utils.hs
+++ b/Rakka/Utils.hs
@@ -1,3 +1,9 @@
+{-# LANGUAGE
+    Arrows
+  , OverloadedStrings
+  , TypeOperators
+  , UnicodeSyntax
+  #-}

 module Rakka.Utils
     ( yesOrNo
     , trueOrFalse
 module Rakka.Utils
     ( yesOrNo
     , trueOrFalse


@@ -10,35 +16,34 @@ module Rakka.Utils
     , mkQueryString
     )
     where
     , mkQueryString
     )
     where

-

 import qualified Codec.Binary.UTF8.String as UTF8
 import           Control.Arrow
 import           Control.Arrow.ArrowList
 import qualified Data.ByteString.Lazy as Lazy (ByteString)
 import qualified Data.ByteString.Lazy.Char8 as L8 hiding (ByteString)
 import qualified Codec.Binary.UTF8.String as UTF8
 import           Control.Arrow
 import           Control.Arrow.ArrowList
 import qualified Data.ByteString.Lazy as Lazy (ByteString)
 import qualified Data.ByteString.Lazy.Char8 as L8 hiding (ByteString)

+import Data.Monoid.Unicode
+import Data.String

 import           Magic
 import           Network.HTTP.Lucu
 import           Network.URI
 import           Magic
 import           Network.HTTP.Lucu
 import           Network.URI

+import Prelude.Unicode

 import           System.IO.Unsafe
 
 import           System.IO.Unsafe
 

-
-yesOrNo :: Bool -> String
+yesOrNo ∷ Bool → String

 yesOrNo True  = "yes"
 yesOrNo False = "no"
 
 yesOrNo True  = "yes"
 yesOrNo False = "no"
 

-
-trueOrFalse :: Bool -> String
+trueOrFalse ∷ Bool → String

 trueOrFalse True  = "true"
 trueOrFalse False = "false"
 
 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
+    = proc str →
+      case str of
+        _ | str ≡ "yes" → returnA ⤙ True
+          | str ≡ "no"  → returnA ⤙ False
+          | otherwise   → returnA ⤙ error ("Expected yes or no: " ⊕ show str)

 
 maybeA :: (ArrowList a, ArrowChoice a) => a b c -> a b (Maybe c)
 maybeA a = listA a
 
 maybeA :: (ArrowList a, ArrowChoice a) => a b c -> a b (Maybe c)
 maybeA a = listA a

diff --git a/Rakka/Validation.hs b/Rakka/Validation.hs
index 73a83e78105c13a1b476b4e6cc107de4293e68f9..417e4f24ce095deabba38d53e4ad82552b85f7e5 100644 (file)
--- a/Rakka/Validation.hs
+++ b/Rakka/Validation.hs
@@ -1,58 +1,39 @@
+{-# LANGUAGE
+    DoAndIfThenElse
+  , UnicodeSyntax
+  #-}

 module Rakka.Validation
     ( getValidator
     )
     where
 module Rakka.Validation
     ( getValidator
     )
     where

-
-import           Control.Arrow
-import           Control.Arrow.ArrowList
-import           Control.Arrow.ArrowTree
-import           Control.Monad.Reader
-import           Paths_Rakka -- Cabal が用意する。
-import           Rakka.Environment
-import           System.Directory
-import           System.FilePath
-import           Text.XML.HXT.Arrow.XmlArrow
-import           Text.XML.HXT.Arrow.XmlIOStateArrow
-import           Text.XML.HXT.DOM.TypeDefs
-import qualified Text.XML.HXT.RelaxNG.Schema as S
-import           Text.XML.HXT.RelaxNG.Validator
-
-
-loadSchema :: FilePath -> IO (IOSArrow XmlTree XmlTree)
+import Control.Applicative
+import Control.Arrow.Unicode
+import Control.Monad.Trans
+import Control.Monad.Unicode
+import Paths_Rakka
+import System.Directory
+import System.FilePath
+import Text.XML.HXT.Arrow.XmlState
+import Text.XML.HXT.DOM.TypeDefs
+import Text.XML.HXT.RelaxNG
+
+loadSchema ∷ FilePath → IO (IOSArrow XmlTree XmlTree)

 loadSchema fpath
 loadSchema fpath

-    = do [schema] <- runX ( setErrorMsgHandler False fail
-                            >>>
-                            readForRelax [] fpath
-                            >>>
-                            perform (validateWithRelaxAndHandleErrors S.relaxSchemaArrow)
-                            >>>
-                            createSimpleForm [] True True True
-                            >>>
-                            perform ( getErrors
-                                      >>>
-                                      getChildren >>> getAttrValue "desc"
-                                      >>>
-                                      arr ("Relax NG validation: " ++ )
-                                      >>>
-                                      mkError c_err
-                                      >>>
-                                      filterErrorMsg
-                                    )
-                          )
-         return $ validateDocumentWithRelax schema
+    = do [schema] ← runX ( setErrorMsgHandler False fail
+                           ⋙
+                           validateSchemaWithRelax fpath
+                         )
+         pure $ validateDocumentWithRelax schema

 
 

-
-doesLocalDirExist :: IO Bool
+doesLocalDirExist ∷ IO Bool

 doesLocalDirExist = doesDirectoryExist "schemas"
 
 doesLocalDirExist = doesDirectoryExist "schemas"
 

-
-getValidator :: MonadIO m => Environment -> FilePath -> m (IOSArrow XmlTree XmlTree)
-getValidator _ fname
+getValidator ∷ MonadIO m ⇒ FilePath → m (IOSArrow XmlTree XmlTree)
+getValidator fname

     = liftIO $
       do let schemaPath = "schemas" </> fname
     = liftIO $
       do let schemaPath = "schemas" </> fname

-
-         localDirExists <- doesLocalDirExist
+         localDirExists ← doesLocalDirExist

          if localDirExists then
              loadSchema schemaPath
          if localDirExists then
              loadSchema schemaPath

-           else
-             getDataFileName ("schemas" </> fname) >>= loadSchema
+         else
+             getDataFileName ("schemas" </> fname) ≫= loadSchema

diff --git a/Rakka/W3CDateTime.hs b/Rakka/W3CDateTime.hs
index 488cd2e08eabe75c3cd76750f10b3acaaa0c7166..4ec4738113b5e0d354349611d57c7648d3361df0 100644 (file)
--- a/Rakka/W3CDateTime.hs
+++ b/Rakka/W3CDateTime.hs
@@ -1,9 +1,9 @@
+-- FIXME: use time-w3c

 module Rakka.W3CDateTime
     ( formatW3CDateTime
     , parseW3CDateTime
     )
     where
 module Rakka.W3CDateTime
     ( formatW3CDateTime
     , parseW3CDateTime
     )
     where

-

 import           Control.Monad
 import           Data.Time
 import           Prelude hiding (min)
 import           Control.Monad
 import           Data.Time
 import           Prelude hiding (min)

diff --git a/Rakka/Wiki.hs b/Rakka/Wiki.hs
index a519d34a227da9b8a40ec6db7b66108907185fc2..bdecec7fac00a5da4b3aa5e86865bc6e2fc91955 100644 (file)
--- a/Rakka/Wiki.hs
+++ b/Rakka/Wiki.hs
@@ -1,3 +1,6 @@
+{-# LANGUAGE
+    UnicodeSyntax
+  #-}

 module Rakka.Wiki
     ( WikiPage
 
 module Rakka.Wiki
     ( WikiPage
 


@@ -17,107 +20,97 @@ module Rakka.Wiki
     , InlineCommand(..)
     )
     where
     , InlineCommand(..)
     )
     where

-
-import           Network.URI
-import           Rakka.Page
-
+import Data.CaseInsensitive (CI)
+import Data.Text (Text)
+import Network.URI
+import Rakka.Page

 
 type WikiPage = [BlockElement]
 
 
 type WikiPage = [BlockElement]
 

-

 data Element
     = Block  !BlockElement
     | Inline !InlineElement
     deriving (Eq, Show)
 
 data Element
     = Block  !BlockElement
     | Inline !InlineElement
     deriving (Eq, Show)
 

-
-type Attribute = (String, String)
-
+type Attribute = (CI Text, Text)

 
 data BlockElement
     = Heading {
 
 data BlockElement
     = Heading {

-        headingLevel :: !Int
-      , headingText  :: !String
+        headingLevel ∷ !Int
+      , headingText  ∷ !Text

       }
     | HorizontalLine
     | List {
       }
     | HorizontalLine
     | List {

-        listType  :: !ListType
-      , listItems :: ![ListItem]
+        listType  ∷ !ListType
+      , listItems ∷ ![ListItem]

       }
     | DefinitionList ![Definition]
       }
     | DefinitionList ![Definition]

-    | Preformatted ![InlineElement]
-    | Paragraph ![InlineElement]
-    | Div ![Attribute] ![Element]
+    | Preformatted   ![InlineElement]
+    | Paragraph      ![InlineElement]
+    | Div            ![Attribute] ![Element]

     | EmptyBlock
     | EmptyBlock

-    | BlockCmd !BlockCommand
+    | BlockCmd       !BlockCommand

     deriving (Eq, Show)
 
     deriving (Eq, Show)
 

-

 data InlineElement
 data InlineElement

-    = Text !String
+    = Text   !Text

     | Italic ![InlineElement]
     | Italic ![InlineElement]

-    | Bold ![InlineElement]
+    | Bold   ![InlineElement]

     | ObjectLink {
     | ObjectLink {

-        objLinkPage :: !PageName
-      , objLinkText :: !(Maybe String)
+        objLinkPage ∷ !PageName
+      , objLinkText ∷ !(Maybe Text)

       }
     | PageLink {
       }
     | PageLink {

-        linkPage     :: !(Maybe PageName)
-      , linkFragment :: !(Maybe String)
-      , linkText     :: !(Maybe String)
+        linkPage     ∷ !(Maybe PageName)
+      , linkFragment ∷ !(Maybe Text)
+      , linkText     ∷ !(Maybe Text)

       }
     | ExternalLink {
       }
     | ExternalLink {

-        extLinkURI  :: !URI
-      , extLinkText :: !(Maybe String)
+        extLinkURI  ∷ !URI
+      , extLinkText ∷ !(Maybe Text)

       }
     | LineBreak ![Attribute]
       }
     | LineBreak ![Attribute]

-    | Span ![Attribute] ![InlineElement]
+    | Span      ![Attribute] ![InlineElement]

     | Image {
     | Image {

-        imgSource :: !(Either URI PageName)
-      , imgAlt    :: !(Maybe String)
+        imgSource ∷ !(Either URI PageName)
+      , imgAlt    ∷ !(Maybe Text)

       }
       }

-    | Anchor ![Attribute] ![InlineElement]
-    | Input ![Attribute]
+    | Anchor    ![Attribute] ![InlineElement]
+    | Input     ![Attribute]

     | EmptyInline
     | InlineCmd !InlineCommand
     deriving (Eq, Show)
 
     | EmptyInline
     | InlineCmd !InlineCommand
     deriving (Eq, Show)
 

-

 data ListType
     = Bullet
     | Numbered
     deriving (Eq, Show)
 
 data ListType
     = Bullet
     | Numbered
     deriving (Eq, Show)
 

-

 type ListItem = [Element]
 
 type ListItem = [Element]
 

-

 data Definition
     = Definition {
 data Definition
     = Definition {

-        defTerm :: ![InlineElement]
-      , defDesc :: ![InlineElement]
+        defTerm ∷ ![InlineElement]
+      , defDesc ∷ ![InlineElement]

       }
     deriving (Eq, Show)
 
       }
     deriving (Eq, Show)
 

-

 data CommandType
     = InlineCommandType
     | BlockCommandType
     deriving (Eq, Show)
 
 data CommandType
     = InlineCommandType
     | BlockCommandType
     deriving (Eq, Show)
 

-

 data BlockCommand
     = BlockCommand {
 data BlockCommand
     = BlockCommand {

-        bCmdName       :: !String
-      , bCmdAttributes :: ![Attribute]
-      , bCmdContents   :: ![BlockElement]
+        bCmdName       ∷ !Text
+      , bCmdAttributes ∷ ![Attribute]
+      , bCmdContents   ∷ ![BlockElement]

       }
     deriving (Eq, Show)
 
       }
     deriving (Eq, Show)
 

-

 data InlineCommand
     = InlineCommand {
 data InlineCommand
     = InlineCommand {

-        iCmdName       :: !String
+        iCmdName       :: !Text

       , iCmdAttributes :: ![Attribute]
       , iCmdContents   :: ![InlineElement]
       }
       , iCmdAttributes :: ![Attribute]
       , iCmdContents   :: ![InlineElement]
       }

diff --git a/Rakka/Wiki/Engine.hs b/Rakka/Wiki/Engine.hs
index 17c2933852ee5273485ac80fcbb570c36f6bd080..02e987cd20f7ed92c6eb7521f3cd2d2e877c6f3f 100644 (file)
--- a/Rakka/Wiki/Engine.hs
+++ b/Rakka/Wiki/Engine.hs
@@ -1,3 +1,10 @@
+{-# LANGUAGE
+    Arrows
+  , OverloadedStrings
+  , ScopedTypeVariables
+  , TypeOperators
+  , UnicodeSyntax
+  #-}

 module Rakka.Wiki.Engine
     ( InterpTable
     , makeMainXHTML
 module Rakka.Wiki.Engine
     ( InterpTable
     , makeMainXHTML


@@ -7,16 +14,25 @@ module Rakka.Wiki.Engine
     , makeDraft
     )
     where
     , makeDraft
     )
     where

-
+import Control.Applicative
+import Control.Arrow
+import Control.Arrow.ArrowIO
+import Control.Arrow.ArrowList
+import Control.Arrow.Unicode
+import Control.Monad.Unicode

 import qualified Codec.Binary.UTF8.String as UTF8
 import qualified Data.ByteString.Lazy as Lazy
 import qualified Data.ByteString.Lazy.Char8 as L8 hiding (ByteString)
 import           Data.Map (Map)
 import qualified Data.Map as M
 import           Data.Maybe
 import qualified Codec.Binary.UTF8.String as UTF8
 import qualified Data.ByteString.Lazy as Lazy
 import qualified Data.ByteString.Lazy.Char8 as L8 hiding (ByteString)
 import           Data.Map (Map)
 import qualified Data.Map as M
 import           Data.Maybe

+import Data.Monoid.Unicode
+import Data.Text (Text)
+import qualified Data.Text as T

 import           Network.HTTP.Lucu
 import           Network.URI
 import           OpenSSL.EVP.Base64
 import           Network.HTTP.Lucu
 import           Network.URI
 import           OpenSSL.EVP.Base64

+import Prelude.Unicode

 import           Rakka.Page
 import           Rakka.Storage
 import           Rakka.SystemConfig
 import           Rakka.Page
 import           Rakka.Storage
 import           Rakka.SystemConfig


@@ -27,44 +43,43 @@ import           Rakka.Wiki.Formatter
 import           Rakka.Wiki.Interpreter
 import           Text.HyperEstraier hiding (getText)
 import           Text.ParserCombinators.Parsec
 import           Rakka.Wiki.Interpreter
 import           Text.HyperEstraier hiding (getText)
 import           Text.ParserCombinators.Parsec

-import           Text.XML.HXT.Arrow hiding (err)
-import           Text.XML.HXT.XPath
-
+import Text.XML.HXT.Arrow.XmlArrow hiding (err)
+import Text.XML.HXT.DOM.TypeDefs
+import Text.XML.HXT.XPath

 
 

-type InterpTable = Map String Interpreter
+type InterpTable = Map Text Interpreter

 
 

-
-wikifyPage :: (ArrowXml a, ArrowChoice a) => InterpTable -> a XmlTree WikiPage
+wikifyPage ∷ (ArrowXml (⇝), ArrowChoice (⇝)) ⇒ InterpTable → XmlTree ⇝ WikiPage

 wikifyPage interpTable
     = proc tree
 wikifyPage interpTable
     = proc tree

-    -> do pType      <- getXPathTreesInDoc "/page/@type/text()" >>> getText >>> arr read -< tree
-          textData   <- maybeA (getXPathTreesInDoc "/page/textData/text()"   >>> getText) -< tree
-          base64Data <- maybeA (getXPathTreesInDoc "/page/binaryData/text()" >>> getText) -< tree
-
-          let dataURI = fmap (binToURI pType) base64Data
-
-          case pType of
-            MIMEType "text" "x-rakka" _
-                -> case parse (wikiPage $ cmdTypeOf interpTable) "" (fromJust textData) of
-                     Left err -> wikifyParseError -< err
-                     Right xs -> returnA -< xs
-
-            MIMEType "image" _ _
-                -- <img src="data:image/png;base64,..." />
-                -> returnA -< [ Paragraph [Image (Left $ fromJust dataURI) Nothing] ]
-
-            _   -> if isJust dataURI then
-                       -- <a href="data:application/zip;base64,...">
-                       --   application/zip
-                       -- </a>
-                       returnA -< [ Paragraph [ Anchor
-                                                [("href", show dataURI)]
-                                                [Text (show pType)]
-                                              ]
-                                  ]
-                   else
-                       -- pre
-                       returnA -< [ Preformatted [Text $ fromJust textData] ]
+    → do pType      ← getXPathTreesInDoc "/page/@type/text()" ⋙ getText ⋙ arr read   ⤙ tree
+         textData   ← maybeA (getXPathTreesInDoc "/page/textData/text()"   ⋙ getText) ⤙ tree
+         base64Data ← maybeA (getXPathTreesInDoc "/page/binaryData/text()" ⋙ getText) ⤙ tree
+
+         let dataURI = binToURI pType <$> base64Data
+
+         case pType of
+           MIMEType "text" "x-rakka" _
+               → case parse (wikiPage $ cmdTypeOf interpTable) "" (fromJust textData) of
+                    Left err → wikifyParseError ⤙ err
+                    Right xs → returnA ⤙ xs
+
+           MIMEType "image" _ _
+               -- <img src="data:image/png;base64,..." />
+               → returnA ⤙ [ Paragraph [Image (Left $ fromJust dataURI) Nothing] ]
+
+           _   → if isJust dataURI then
+                     -- <a href="data:application/zip;base64,...">
+                     --   application/zip
+                     -- </a>
+                     returnA ⤙ [ Paragraph [ Anchor
+                                               [("href", T.pack $ show dataURI)]
+                                               [Text (T.pack $ show pType)]
+                                           ]
+                               ]
+                 else
+                     -- pre
+                     returnA ⤙ [ Preformatted [Text ∘ T.pack $ fromJust textData] ]

     where
       binToURI :: MIMEType -> String -> URI
       binToURI pType base64Data
     where
       binToURI :: MIMEType -> String -> URI
       binToURI pType base64Data


@@ -80,35 +95,34 @@ wikifyPage interpTable
           | otherwise        = x : stripWhiteSpace xs
 
 
           | otherwise        = x : stripWhiteSpace xs
 
 

-wikifyBin :: (ArrowXml a, ArrowChoice a) => InterpTable -> a (MIMEType, Lazy.ByteString) WikiPage
+wikifyBin :: (ArrowXml (⇝), ArrowChoice (⇝)) ⇒ InterpTable → (MIMEType, Lazy.ByteString) ⇝ WikiPage

 wikifyBin interpTable
     = proc (pType, pBin)
 wikifyBin interpTable
     = proc (pType, pBin)

-    -> do let text    = UTF8.decode $ Lazy.unpack pBin
-              dataURI = binToURI pType pBin
-
-          case pType of
-            MIMEType "text" "x-rakka" _
-                -> case parse (wikiPage $ cmdTypeOf interpTable) "" text of
-                     Left err -> wikifyParseError -< err
-                     Right xs -> returnA -< xs
-
-            MIMEType "image" _ _
-                -- <img src="data:image/png;base64,..." />
-                -> returnA -< [ Paragraph [Image (Left dataURI) Nothing] ]
-
-            
-            _
-                -- <a href="data:application/zip;base64,...">
-                --   application/zip (19372 bytes)
-                -- </a>
-                -> returnA -< [ Paragraph [ Anchor
-                                            [("href", show dataURI)]
-                                            [Text (show pType ++
-                                                   " (" ++
-                                                   show (Lazy.length pBin) ++
-                                                   " bytes)")]
-                                          ]
-                              ]
+    → do let text    = UTF8.decode $ Lazy.unpack pBin
+             dataURI = binToURI pType pBin
+
+         case pType of
+           MIMEType "text" "x-rakka" _
+               -> case parse (wikiPage $ cmdTypeOf interpTable) "" text of
+                    Left err -> wikifyParseError -< err
+                    Right xs -> returnA -< xs
+
+           MIMEType "image" _ _
+               -- <img src="data:image/png;base64,..." />
+               -> returnA -< [ Paragraph [Image (Left dataURI) Nothing] ]
+
+           _   -- <a href="data:application/zip;base64,...">
+               --   application/zip (19372 bytes)
+               -- </a>
+               -> returnA -< [ Paragraph [ Anchor
+                                           [("href", T.pack $ show dataURI)]
+                                           [Text (T.concat [ T.pack $ show pType
+                                                           , "("
+                                                           , T.pack ∘ show $ Lazy.length pBin
+                                                           , " bytes)"
+                                                           ])]
+                                         ]
+                             ]

     where
       binToURI :: MIMEType -> Lazy.ByteString -> URI
       binToURI m b
     where
       binToURI :: MIMEType -> Lazy.ByteString -> URI
       binToURI m b


@@ -117,25 +131,25 @@ wikifyBin interpTable
             , uriPath   = show m ++ ";base64," ++ (L8.unpack $ encodeBase64LBS b)
             }
 
             , uriPath   = show m ++ ";base64," ++ (L8.unpack $ encodeBase64LBS b)
             }
 

-
-cmdTypeOf :: InterpTable -> String -> Maybe CommandType
+cmdTypeOf ∷ Alternative f ⇒ InterpTable → Text → f CommandType

 cmdTypeOf interpTable name
 cmdTypeOf interpTable name

-    = fmap commandType (M.lookup name interpTable)
-
-
-makeMainXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
-                 Storage
-              -> SystemConfig
-              -> InterpTable
-              -> a XmlTree XmlTree
+    = case M.lookup name interpTable of
+        Just t  → pure $ commandType t
+        Nothing → empty
+
+makeMainXHTML ∷ (ArrowXml (⇝), ArrowChoice (⇝), ArrowIO (⇝))
+              ⇒ Storage
+              → SystemConfig
+              → InterpTable
+              → XmlTree ⇝ XmlTree

 makeMainXHTML sto sysConf interpTable
     = proc tree
 makeMainXHTML sto sysConf interpTable
     = proc tree

-    -> do BaseURI baseURI <- getSysConfA sysConf -< ()
-          wiki            <- wikifyPage interpTable -< tree
-          pName           <- getXPathTreesInDoc "/page/@name/text()" >>> getText -< tree
-          interpreted     <- interpretCommands sto sysConf interpTable
-                             -< (Just pName, Just tree, Just wiki, wiki)
-          formatWikiBlocks -< (baseURI, interpreted)
+    → do BaseURI baseURI ← getSysConfA sysConf    ⤙ ()
+         wiki            ← wikifyPage interpTable ⤙ tree
+         pName           ← getXPathTreesInDoc "/page/@name/text()" ⋙ getText ⤙ tree
+         interpreted     ← interpretCommands sto sysConf interpTable
+                           ⤙ (Just (T.pack pName), Just tree, Just wiki, wiki)
+         formatWikiBlocks ⤙ (baseURI, interpreted)

 
 
 makeSubXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
 
 
 makeSubXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>


@@ -220,115 +234,112 @@ interpretCommands sto sysConf interpTable
                desc' <- mapM (interpInline ctx) desc
                return (Definition term' desc')
 
                desc' <- mapM (interpInline ctx) desc
                return (Definition term' desc')
 

-      interpBlockCommand :: InterpreterContext -> BlockCommand -> IO BlockElement
+      interpBlockCommand ∷ InterpreterContext → BlockCommand → IO BlockElement

       interpBlockCommand ctx cmd
           = case M.lookup (bCmdName cmd) interpTable of
               Nothing
       interpBlockCommand ctx cmd
           = case M.lookup (bCmdName cmd) interpTable of
               Nothing

-                  -> fail ("no such interpreter: " ++ bCmdName cmd)
+                  → fail ("no such interpreter: " ⊕ T.unpack (bCmdName cmd))

 
               Just interp
 
               Just interp

-                  -> bciInterpret interp ctx cmd
-                     >>=
-                     interpBlock ctx
+                  → bciInterpret interp ctx cmd
+                    ≫=
+                    interpBlock ctx

 
 

-      interpInlineCommand :: InterpreterContext -> InlineCommand -> IO InlineElement
+      interpInlineCommand ∷ InterpreterContext → InlineCommand → IO InlineElement

       interpInlineCommand ctx cmd
           = case M.lookup (iCmdName cmd) interpTable of
               Nothing
       interpInlineCommand ctx cmd
           = case M.lookup (iCmdName cmd) interpTable of
               Nothing

-                  -> fail ("no such interpreter: " ++ iCmdName cmd)
+                  → fail ("no such interpreter: " ⊕ T.unpack (iCmdName cmd))

 
               Just interp
 
               Just interp

-                  -> iciInterpret interp ctx cmd
-                     >>=
-                     interpInline ctx
-
+                  → iciInterpret interp ctx cmd ≫= interpInline ctx

 
 

-makeDraft :: (ArrowXml a, ArrowChoice a, ArrowIO a) => InterpTable -> a XmlTree Document
+makeDraft ∷ ∀(⇝). (ArrowXml (⇝), ArrowChoice (⇝), ArrowIO (⇝)) ⇒ InterpTable → XmlTree ⇝ Document

 makeDraft interpTable
 makeDraft interpTable

-    = proc tree ->
-      do redir <- maybeA (getXPathTreesInDoc "/page/@redirect") -< tree
+    = proc tree →
+      do redir ← maybeA (getXPathTreesInDoc "/page/@redirect") ⤙ tree

          case redir of
          case redir of

-           Nothing -> makeEntityDraft   -< tree
-           Just _  -> makeRedirectDraft -< tree
+           Nothing → makeEntityDraft   ⤙ tree
+           Just _  → makeRedirectDraft ⤙ tree

     where
     where

-      makeEntityDraft :: (ArrowXml a, ArrowChoice a, ArrowIO a) => a XmlTree Document
+      makeEntityDraft ∷ XmlTree ⇝ Document

       makeEntityDraft 
       makeEntityDraft 

-          = proc tree ->
-            do doc <- arrIO0 newDocument -< ()
+          = proc tree →
+            do doc ← arrIO0 newDocument ⤙ ()

          
          

-               pName     <- getXPathTreesInDoc "/page/@name/text()"         >>> getText -< tree
-               pType     <- getXPathTreesInDoc "/page/@type/text()"         >>> getText -< tree
-               pLastMod  <- getXPathTreesInDoc "/page/@lastModified/text()" >>> getText -< tree
-               pIsLocked <- getXPathTreesInDoc "/page/@isLocked/text()"     >>> getText -< tree
-               pIsBinary <- getXPathTreesInDoc "/page/@isBinary/text()"     >>> getText -< tree
-               pRevision <- getXPathTreesInDoc "/page/@revision/text()"     >>> getText -< tree
-               pLang     <- maybeA (getXPathTreesInDoc "/page/@lang/text()"     >>> getText) -< tree
-               pIsTheme  <- maybeA (getXPathTreesInDoc "/page/@isTheme/text()"  >>> getText) -< tree
-               pIsFeed   <- maybeA (getXPathTreesInDoc "/page/@isFeed/text()"   >>> getText) -< tree
-               pSummary  <- maybeA (getXPathTreesInDoc "/page/summary/text()"   >>> getText) -< tree
-
-               arrIO2 setURI                               -< (doc, Just $ mkRakkaURI pName)
-               arrIO2 (flip setAttribute "@title"        ) -< (doc, Just pName)
-               arrIO2 (flip setAttribute "@type"         ) -< (doc, Just pType)
-               arrIO2 (flip setAttribute "@mdate"        ) -< (doc, Just pLastMod)
-               arrIO2 (flip setAttribute "@lang"         ) -< (doc, pLang)
-               arrIO2 (flip setAttribute "rakka:isLocked") -< (doc, Just pIsLocked)
-               arrIO2 (flip setAttribute "rakka:isBinary") -< (doc, Just pIsBinary)
-               arrIO2 (flip setAttribute "rakka:revision") -< (doc, Just pRevision)
-               arrIO2 (flip setAttribute "rakka:summary" ) -< (doc, pSummary)
-
-               arrIO2 addHiddenText -< (doc, pName)
+               pName     ← getXPathTreesInDoc "/page/@name/text()"         ⋙ getText ⤙ tree
+               pType     ← getXPathTreesInDoc "/page/@type/text()"         ⋙ getText ⤙ tree
+               pLastMod  ← getXPathTreesInDoc "/page/@lastModified/text()" ⋙ getText ⤙ tree
+               pIsLocked ← getXPathTreesInDoc "/page/@isLocked/text()"     ⋙ getText ⤙ tree
+               pIsBinary ← getXPathTreesInDoc "/page/@isBinary/text()"     ⋙ getText ⤙ tree
+               pRevision ← getXPathTreesInDoc "/page/@revision/text()"     ⋙ getText ⤙ tree
+               pLang     ← maybeA (getXPathTreesInDoc "/page/@lang/text()"     ⋙ getText) ⤙ tree
+               pIsTheme  ← maybeA (getXPathTreesInDoc "/page/@isTheme/text()"  ⋙ getText) ⤙ tree
+               pIsFeed   ← maybeA (getXPathTreesInDoc "/page/@isFeed/text()"   ⋙ getText) ⤙ tree
+               pSummary  ← maybeA (getXPathTreesInDoc "/page/summary/text()"   ⋙ getText) ⤙ tree
+
+               arrIO2 setURI                               ⤙ (doc, Just ∘ mkRakkaURI $ T.pack pName    )
+               arrIO2 (flip setAttribute "@title"        ) ⤙ (doc, Just              $ T.pack pName    )
+               arrIO2 (flip setAttribute "@type"         ) ⤙ (doc, Just              $ T.pack pType    )
+               arrIO2 (flip setAttribute "@mdate"        ) ⤙ (doc, Just              $ T.pack pLastMod )
+               arrIO2 (flip setAttribute "@lang"         ) ⤙ (doc, T.pack <$> pLang)
+               arrIO2 (flip setAttribute "rakka:isLocked") ⤙ (doc, Just              $ T.pack pIsLocked)
+               arrIO2 (flip setAttribute "rakka:isBinary") ⤙ (doc, Just              $ T.pack pIsBinary)
+               arrIO2 (flip setAttribute "rakka:revision") ⤙ (doc, Just              $ T.pack pRevision)
+               arrIO2 (flip setAttribute "rakka:summary" ) ⤙ (doc, T.pack <$> pSummary)
+
+               arrIO2 addHiddenText ⤙ (doc, T.pack pName)

 
                case pSummary of
 
                case pSummary of

-                 Just s  -> arrIO2 addHiddenText -< (doc, s)
-                 Nothing -> returnA -< ()
+                 Just s  → arrIO2 addHiddenText ⤙ (doc, T.pack s)
+                 Nothing → returnA ⤙ ()

 
                -- otherLang はリンク先ページ名を hidden text で入れる。
 
                -- otherLang はリンク先ページ名を hidden text で入れる。

-               otherLangs <- listA (getXPathTreesInDoc "/page/otherLang/link/@page/text()" >>> getText) -< tree
+               otherLangs ← listA (getXPathTreesInDoc "/page/otherLang/link/@page/text()" ⋙ getText) ⤙ tree

                listA ( (arr fst &&& arrL snd)
                listA ( (arr fst &&& arrL snd)

-                       >>>
+                       ⋙

                        arrIO2 addHiddenText
                        arrIO2 addHiddenText

-                       >>>
+                       ⋙

                        none
                        none

-                     ) -< (doc, otherLangs)
+                     ) ⤙ (doc, T.pack <$> otherLangs)

 
                case read pType of
                  MIMEType "text" "css" _
 
                case read pType of
                  MIMEType "text" "css" _

-                     -> arrIO2 (flip setAttribute "rakka:isTheme") -< (doc, pIsTheme)
+                     → arrIO2 (flip setAttribute "rakka:isTheme") ⤙ (doc, T.pack <$> pIsTheme)

            
                  MIMEType "text" "x-rakka" _
            
                  MIMEType "text" "x-rakka" _

-                   -- wikify して興味のある部分を addText する。
-                   -> do arrIO2 (flip setAttribute "rakka:isFeed") -< (doc, pIsFeed)
-                         wiki <- wikifyPage interpTable -< tree
-                         arrIO2 (mapM_ . addBlockText) -< (doc, wiki)
+                     -- wikify して興味のある部分を addText する。
+                     → do arrIO2 (flip setAttribute "rakka:isFeed") ⤙ (doc, T.pack <$> pIsFeed)
+                          wiki ← wikifyPage interpTable ⤙ tree
+                          arrIO2 (mapM_ ∘ addBlockText) ⤙ (doc, wiki)

 
                  MIMEType _ _ _
 
                  MIMEType _ _ _

-                     -> returnA -< ()
+                     → returnA ⤙ ()

 
 

-               returnA -< doc
+               returnA ⤙ doc

 
 

-      makeRedirectDraft :: (ArrowXml a, ArrowChoice a, ArrowIO a) => a XmlTree Document
+      makeRedirectDraft ∷ XmlTree ⇝ Document

       makeRedirectDraft
       makeRedirectDraft

-          = proc tree ->
-            do doc <- arrIO0 newDocument -< ()
+          = proc tree →
+            do doc ← arrIO0 newDocument ⤙ ()

 
 

-               pName     <- getXPathTreesInDoc "/page/@name/text()"         >>> getText -< tree
-               pRedir    <- getXPathTreesInDoc "/page/@redirect/text()"     >>> getText -< tree
-               pIsLocked <- getXPathTreesInDoc "/page/@isLocked/text()"     >>> getText -< tree
-               pRevision <- getXPathTreesInDoc "/page/@revision/text()"     >>> getText -< tree
-               pLastMod  <- getXPathTreesInDoc "/page/@lastModified/text()" >>> getText -< tree
+               pName     ← getXPathTreesInDoc "/page/@name/text()"         ⋙ getText ⤙ tree
+               pRedir    ← getXPathTreesInDoc "/page/@redirect/text()"     ⋙ getText ⤙ tree
+               pIsLocked ← getXPathTreesInDoc "/page/@isLocked/text()"     ⋙ getText ⤙ tree
+               pRevision ← getXPathTreesInDoc "/page/@revision/text()"     ⋙ getText ⤙ tree
+               pLastMod  ← getXPathTreesInDoc "/page/@lastModified/text()" ⋙ getText ⤙ tree

 
 

-               arrIO2 setURI                               -< (doc, Just $ mkRakkaURI pName)
-               arrIO2 (flip setAttribute "@title"        ) -< (doc, Just pName)
+               arrIO2 setURI                               -< (doc, Just ∘ mkRakkaURI $ T.pack pName      )
+               arrIO2 (flip setAttribute "@title"        ) -< (doc, Just              $ T.pack pName      )

                arrIO2 (flip setAttribute "@type"         ) -< (doc, Just "application/x-rakka-redirection")
                arrIO2 (flip setAttribute "@type"         ) -< (doc, Just "application/x-rakka-redirection")

-               arrIO2 (flip setAttribute "@mdate"        ) -< (doc, Just pLastMod)
-               arrIO2 (flip setAttribute "rakka:isLocked") -< (doc, Just pIsLocked)
-               arrIO2 (flip setAttribute "rakka:revision") -< (doc, Just pRevision)
+               arrIO2 (flip setAttribute "@mdate"        ) -< (doc, Just              $ T.pack pLastMod   )
+               arrIO2 (flip setAttribute "rakka:isLocked") -< (doc, Just              $ T.pack pIsLocked  )
+               arrIO2 (flip setAttribute "rakka:revision") -< (doc, Just              $ T.pack pRevision  )

 
                -- リダイレクト先ページ名はテキストとして入れる
 
                -- リダイレクト先ページ名はテキストとして入れる

-               arrIO2 addText -< (doc, pRedir)
+               arrIO2 addText ⤙ (doc, T.pack pRedir)

 
 

-               returnA -< doc
+               returnA ⤙ doc

 
       addElemText :: Document -> Element -> IO ()
       addElemText doc (Block  b) = addBlockText  doc b
 
       addElemText :: Document -> Element -> IO ()
       addElemText doc (Block  b) = addBlockText  doc b


@@ -345,23 +356,23 @@ makeDraft interpTable
       addBlockText _    EmptyBlock            = return ()
       addBlockText doc (BlockCmd bcmd)        = addBlockCmdText doc bcmd
 
       addBlockText _    EmptyBlock            = return ()
       addBlockText doc (BlockCmd bcmd)        = addBlockCmdText doc bcmd
 

-      addInlineText :: Document -> InlineElement -> IO ()
+      addInlineText ∷ Document → InlineElement → IO ()

       addInlineText doc (Text text)                       = addText doc text
       addInlineText doc (Italic inlines)                  = mapM_ (addInlineText doc) inlines
       addInlineText doc (Bold inlines)                    = mapM_ (addInlineText doc) inlines
       addInlineText doc (ObjectLink page Nothing)         = addText doc page
       addInlineText doc (ObjectLink page (Just text))     = addHiddenText doc page
       addInlineText doc (Text text)                       = addText doc text
       addInlineText doc (Italic inlines)                  = mapM_ (addInlineText doc) inlines
       addInlineText doc (Bold inlines)                    = mapM_ (addInlineText doc) inlines
       addInlineText doc (ObjectLink page Nothing)         = addText doc page
       addInlineText doc (ObjectLink page (Just text))     = addHiddenText doc page

-                                                            >> addText doc text
-      addInlineText doc (PageLink page fragm Nothing)     = addText doc (fromMaybe "" page ++ fromMaybe "" fragm)
-      addInlineText doc (PageLink page fragm (Just text)) = addHiddenText doc (fromMaybe "" page ++ fromMaybe "" fragm)
-                                                            >> addText doc text
-      addInlineText doc (ExternalLink uri Nothing)        = addText doc (uriToString id uri "")
-      addInlineText doc (ExternalLink uri (Just text))    = addHiddenText doc (uriToString id uri "")
-                                                            >> addText doc text
+                                                            *> addText    doc text
+      addInlineText doc (PageLink page fragm Nothing)     = addText       doc (fromMaybe (∅) page ⊕ maybe (∅) (T.cons '#') fragm)
+      addInlineText doc (PageLink page fragm (Just text)) = addHiddenText doc (fromMaybe (∅) page ⊕ maybe (∅) (T.cons '#') fragm)
+                                                            *> addText    doc text
+      addInlineText doc (ExternalLink uri Nothing)        = addText       doc (T.pack $ uriToString id uri "")
+      addInlineText doc (ExternalLink uri (Just text))    = addHiddenText doc (T.pack $ uriToString id uri "")
+                                                            *> addText    doc text

       addInlineText _   (LineBreak _)                     = return ()
       addInlineText doc (Span _ inlines)                  = mapM_ (addInlineText doc) inlines
       addInlineText doc (Image src alt)                   = do case src of
       addInlineText _   (LineBreak _)                     = return ()
       addInlineText doc (Span _ inlines)                  = mapM_ (addInlineText doc) inlines
       addInlineText doc (Image src alt)                   = do case src of

-                                                                 Left  uri  -> addHiddenText doc (uriToString id uri "")
+                                                                 Left  uri  -> addHiddenText doc (T.pack $ uriToString id uri "")

                                                                  Right page -> addHiddenText doc page
                                                                case alt of
                                                                  Just text -> addHiddenText doc text
                                                                  Right page -> addHiddenText doc page
                                                                case alt of
                                                                  Just text -> addHiddenText doc text


@@ -386,18 +397,18 @@ makeDraft interpTable
       addInlineCmdText doc (InlineCommand _ _ inlines) = mapM_ (addInlineText doc) inlines
 
 
       addInlineCmdText doc (InlineCommand _ _ inlines) = mapM_ (addInlineText doc) inlines
 
 

-makePageLinkList :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
-                Storage
-             -> SystemConfig
-             -> InterpTable
-             -> a XmlTree [PageName]
+makePageLinkList ∷ (ArrowXml (⇝), ArrowChoice (⇝), ArrowIO (⇝))
+                 ⇒ Storage
+                 → SystemConfig
+                 → InterpTable
+                 → XmlTree ⇝ [PageName]

 makePageLinkList sto sysConf interpTable
     = proc tree
 makePageLinkList sto sysConf interpTable
     = proc tree

-    -> do wiki            <- wikifyPage interpTable -< tree
-          pName           <- getXPathTreesInDoc "/page/@name/text()" >>> getText -< tree
-          interpreted     <- interpretCommands sto sysConf interpTable
-                             -< (Just pName, Just tree, Just wiki, wiki)
-          returnA -< concatMap extractFromBlock interpreted
+    → do wiki        ← wikifyPage interpTable ⤙ tree
+         pName       ← getXPathTreesInDoc "/page/@name/text()" ⋙ getText ⤙ tree
+         interpreted ← interpretCommands sto sysConf interpTable
+                       ⤙ (Just (T.pack pName), Just tree, Just wiki, wiki)
+         returnA ⤙ concatMap extractFromBlock interpreted

     where
       extractFromElem :: Element -> [PageName]
       extractFromElem (Block  b) = extractFromBlock  b
     where
       extractFromElem :: Element -> [PageName]
       extractFromElem (Block  b) = extractFromBlock  b


@@ -427,8 +438,7 @@ makePageLinkList sto sysConf interpTable
             ++
             concatMap extractFromInline desc
 
             ++
             concatMap extractFromInline desc
 

-
-wikifyParseError :: Arrow a => a ParseError WikiPage
+wikifyParseError ∷ Arrow (⇝) ⇒ ParseError ⇝ WikiPage

 wikifyParseError = proc err
 wikifyParseError = proc err

-                 -> returnA -< [Div [("class", "error")]
-                                [ Block (Preformatted [Text (show err)]) ]]
+                 → returnA -< [Div [("class", "error")]
+                                [ Block (Preformatted [Text (T.pack $ show err)]) ]]

diff --git a/Rakka/Wiki/Formatter.hs b/Rakka/Wiki/Formatter.hs
index 5f7c7d8c10b952a1c7d7df404da7bc1667e2113c..c1e63f5c05138ab1a4caa4b4de7f84b3dd8a49fe 100644 (file)
--- a/Rakka/Wiki/Formatter.hs
+++ b/Rakka/Wiki/Formatter.hs
@@ -1,19 +1,30 @@
+{-# LANGUAGE
+    Arrows
+  , OverloadedStrings
+  , TypeOperators
+  , UnicodeSyntax
+  , ViewPatterns
+  #-}

 module Rakka.Wiki.Formatter
     ( formatWikiBlocks
     )
     where
 module Rakka.Wiki.Formatter
     ( formatWikiBlocks
     )
     where

-
-import           Control.Arrow
-import           Control.Arrow.ArrowIf
-import           Control.Arrow.ArrowList
-import           Control.Arrow.ArrowTree
-import           Data.Maybe
-import           Network.URI hiding (fragment)
-import           Rakka.Page
-import           Rakka.Wiki
-import           Text.XML.HXT.Arrow.XmlArrow
-import           Text.XML.HXT.DOM.TypeDefs
-
+import Control.Arrow
+import Control.Arrow.ArrowIf
+import Control.Arrow.ArrowList
+import Control.Arrow.ArrowTree
+import Control.Arrow.Unicode
+import qualified Data.CaseInsensitive as CS
+import Data.Maybe
+import Data.Monoid.Unicode
+import Data.Text (Text)
+import qualified Data.Text as T
+import Network.URI hiding (fragment)
+import Prelude.Unicode
+import Rakka.Page
+import Rakka.Wiki
+import Text.XML.HXT.Arrow.XmlArrow
+import Text.XML.HXT.DOM.TypeDefs

 
 formatWikiBlocks :: (ArrowXml a, ArrowChoice a) => a (URI, [BlockElement]) XmlTree
 formatWikiBlocks
 
 formatWikiBlocks :: (ArrowXml a, ArrowChoice a) => a (URI, [BlockElement]) XmlTree
 formatWikiBlocks


@@ -30,13 +41,12 @@ formatElement
          Block  b -> formatBlock  -< (baseURI, b)
          Inline i -> formatInline -< (baseURI, i)
 
          Block  b -> formatBlock  -< (baseURI, b)
          Inline i -> formatInline -< (baseURI, i)
 

-
-formatBlock :: (ArrowXml a, ArrowChoice a) => a (URI, BlockElement) XmlTree
+formatBlock ∷ (ArrowXml (⇝), ArrowChoice (⇝)) ⇒ (URI, BlockElement) ⇝ XmlTree

 formatBlock 
     = proc (baseURI, block)
 formatBlock 
     = proc (baseURI, block)

-    -> case block of
+    → case block of

          Heading level text
          Heading level text

-             -> formatHeading -< (level, text)
+             → formatHeading ⤙ (level, text)

 
          HorizontalLine
              -> eelem "hr" -< ()
 
          HorizontalLine
              -> eelem "hr" -< ()


@@ -78,12 +88,12 @@ formatBlock
              ) -< (baseURI, (attrs, contents))
 
 
              ) -< (baseURI, (attrs, contents))
 
 

-formatHeading :: ArrowXml a => a (Int, String) XmlTree
+formatHeading ∷ ArrowXml (⇝) ⇒ (Int, Text) ⇝ XmlTree

 formatHeading 
 formatHeading 

-    = proc (level, text)
-    -> mkelem ("h" ++ show level)
+    = proc (level, T.unpack → text)
+    -> mkelem ("h" ⊕ show level)

        [ sattr "id" text ]
        [ sattr "id" text ]

-       [ txt text        ] -<< ()
+       [ txt text        ] ⤛ ()

 
 
 formatListElement :: (ArrowXml a, ArrowChoice a) => a (URI, BlockElement) XmlTree
 
 
 formatListElement :: (ArrowXml a, ArrowChoice a) => a (URI, BlockElement) XmlTree


@@ -154,13 +164,12 @@ formatParagraph
            formatInline
          )
 
            formatInline
          )
 

-
-formatInline :: (ArrowXml a, ArrowChoice a) => a (URI, InlineElement) XmlTree
+formatInline ∷ (ArrowXml (⇝), ArrowChoice (⇝)) ⇒ (URI, InlineElement) ⇝ XmlTree

 formatInline 
     = proc (baseURI, i)
 formatInline 
     = proc (baseURI, i)

-    -> case i of
+    → case i of

          Text text
          Text text

-             -> mkText -< text
+             → mkText ⤙ T.unpack text

 
          Italic contents
              -> formatElem "i" -< (baseURI, [], contents)
 
          Italic contents
              -> formatElem "i" -< (baseURI, [], contents)


@@ -197,87 +206,78 @@ formatInline
 
          _   -> arr (error . ("formatInline: unsupported InlineElement: " ++) . show) -< i
     where
 
          _   -> arr (error . ("formatInline: unsupported InlineElement: " ++) . show) -< i
     where

-      formatElem :: (ArrowXml a, ArrowChoice a) =>
+      formatElem ∷ (ArrowXml (⇝), ArrowChoice (⇝)) ⇒

                     String
                     String

-                 -> a (URI, [Attribute], [InlineElement]) XmlTree
+                 → (URI, [Attribute], [InlineElement]) ⇝ XmlTree

       formatElem name
           = proc (baseURI, attrs, contents)
       formatElem name
           = proc (baseURI, attrs, contents)

-          -> ( eelem name
-               += ( arrL (fst . snd)
-                       >>>
-                       attrFromPair
+          → ( eelem name
+               += ( arrL (fst ∘ snd)
+                    ⋙
+                    attrFromPair

                   )
                += ( (arr fst &&& arrL (snd . snd))
                   )
                += ( (arr fst &&& arrL (snd . snd))

-                    >>>
+                    ⋙

                     formatInline
                   )
                     formatInline
                   )

-             ) -< (baseURI, (attrs, contents))
+             ) ⤙ (baseURI, (attrs, contents))

 
 

+attrFromPair ∷ ArrowXml (⇝) ⇒ Attribute ⇝ XmlTree
+attrFromPair = proc (T.unpack ∘ CS.original → name, T.unpack → value)
+             → attr name (txt value) ⤛ ()

 
 

-attrFromPair :: (ArrowXml a) => a (String, String) XmlTree
-attrFromPair = proc (name, value)
-             -> attr name (txt value) -<< ()
-
-
-formatObjectLink :: (ArrowXml a) => a (URI, InlineElement) XmlTree
+formatObjectLink ∷ ArrowXml (⇝) ⇒ (URI, InlineElement) ⇝ XmlTree

 formatObjectLink 
     = proc (baseURI, ObjectLink page text)
 formatObjectLink 
     = proc (baseURI, ObjectLink page text)

-    -> let uri   = mkObjectURI baseURI page
-           href  = uriToString id uri ""
-           label = fromMaybe ("{" ++ page ++ "}") text
-       in
-         mkAnchor -< (href, label)
+    → let uri   = mkObjectURI baseURI page
+          label = fromMaybe ("{" ⊕ page ⊕ "}") text
+      in
+        mkAnchor ⤙ (uri, label)

 
 

-
-formatPageLink :: (ArrowXml a) => a (URI, InlineElement) XmlTree
+formatPageLink ∷ ArrowXml (⇝) ⇒ (URI, InlineElement) ⇝ XmlTree

 formatPageLink 
     = proc (baseURI, PageLink page fragment text)
 formatPageLink 
     = proc (baseURI, PageLink page fragment text)

-    -> let uri    = case (page, fragment) of
-                      (Just  x, Just  y) -> mkPageFragmentURI baseURI x y
-                      (Just  x, Nothing) -> mkPageURI baseURI x
-                      (Nothing, Just  y) -> mkFragmentURI y
-                      _                  -> undefined
-           href   = uriToString id uri ""
-           dLabel = fromMaybe "" page ++ fromMaybe "" (fmap ('#':) fragment)
-           label  = fromMaybe dLabel text
-       in
-         mkAnchor -< (href, label)
-
-
-formatImage :: (ArrowXml a) => a (URI, InlineElement) XmlTree
+    → let uri    = case (page, fragment) of
+                      (Just  x, Just  y) → mkPageFragmentURI baseURI x y
+                      (Just  x, Nothing) → mkPageURI baseURI x
+                      (Nothing, Just  y) → mkFragmentURI y
+                      _                  → (⊥)
+          dLabel = fromMaybe (∅) page ⊕ maybe (∅) (T.cons '#') fragment
+          label  = fromMaybe dLabel text
+      in
+        mkAnchor ⤙ (uri, label)
+
+formatImage ∷ ArrowXml (⇝) ⇒ (URI, InlineElement) ⇝ XmlTree

 formatImage = proc (baseURI, Image src alt)
 formatImage = proc (baseURI, Image src alt)

-            -> let uri  = case src of
-                            Left  u    -> u
-                            Right name -> mkObjectURI baseURI name
-                   href = uriToString id uri ""
-               in
-                 ( eelem "img"
-                   += sattr "src" href
-                   += ( case alt of
-                          Just x  -> sattr "alt" x
-                          Nothing -> none
-                      )
-                 ) -<< ()
-
-
-formatExternalLink :: (ArrowXml a) => a InlineElement XmlTree
+            → let uri  = case src of
+                           Left  u    → u
+                           Right name → mkObjectURI baseURI name
+                  href = uriToString id uri ""
+              in
+                ( eelem "img"
+                  += sattr "src" href
+                  += ( case alt of
+                         Just x  → sattr "alt" (T.unpack x)
+                         Nothing → none
+                     )
+                ) ⤛ ()
+
+
+formatExternalLink ∷ ArrowXml (⇝) ⇒ InlineElement ⇝ XmlTree

 formatExternalLink 
     = proc (ExternalLink uri text)
 formatExternalLink 
     = proc (ExternalLink uri text)

-    -> let href  = uriToString id uri ""
-           label = fromMaybe href text
-       in
-         mkAnchor -< (href, label)
+    → let href  = uriToString id uri ""
+          label = fromMaybe (T.pack href) text
+      in
+        mkAnchor -< (uri, label)

 
 

-
-mkAnchor :: (ArrowXml a) => a (String, String) XmlTree
+mkAnchor ∷ ArrowXml (⇝) ⇒ (URI, Text) ⇝ XmlTree

 mkAnchor = eelem "a"
 mkAnchor = eelem "a"

-           += attr "href" (arr fst >>> mkText)
-           += (arr snd >>> mkText)
-
+           += attr "href" (arr (flip (uriToString id) "" ∘ fst) ⋙ mkText)
+           += (arr (T.unpack ∘ snd) ⋙ mkText)

 
 

-attachXHtmlNS :: (ArrowXml a) => a XmlTree XmlTree
+attachXHtmlNS ∷ ArrowXml (⇝) ⇒ XmlTree ⇝ XmlTree

 attachXHtmlNS = processTopDown (changeQName attach `when` isElem)
     where
 attachXHtmlNS = processTopDown (changeQName attach `when` isElem)
     where

-      attach :: QName -> QName
-      attach = setNamePrefix'   (newXName "xhtml") .
-               setNamespaceUri' (newXName "http://www.w3.org/1999/xhtml")
+      attach ∷ QName → QName
+      attach = setNamespaceUri' (newXName "http://www.w3.org/1999/xhtml")

diff --git a/Rakka/Wiki/Interpreter.hs b/Rakka/Wiki/Interpreter.hs
index 32e1a3aa0e1760516d67e533b2fdb59a1942df43..6bce1d06032f31277acf8be2a09285b2effa4adf 100644 (file)
--- a/Rakka/Wiki/Interpreter.hs
+++ b/Rakka/Wiki/Interpreter.hs
@@ -1,3 +1,6 @@
+{-# LANGUAGE
+    UnicodeSyntax
+  #-}

 module Rakka.Wiki.Interpreter
     ( Interpreter(..)
     , InterpreterContext(..)
 module Rakka.Wiki.Interpreter
     ( Interpreter(..)
     , InterpreterContext(..)


@@ -6,22 +9,21 @@ module Rakka.Wiki.Interpreter
     , commandType -- private
     )
     where
     , commandType -- private
     )
     where

-
-import           Rakka.Page
-import           Rakka.Storage
-import           Rakka.SystemConfig
-import           Rakka.Wiki
-import           Text.XML.HXT.DOM.TypeDefs
-
+import Data.Text (Text)
+import Rakka.Page
+import Rakka.Storage
+import Rakka.SystemConfig
+import Rakka.Wiki
+import Text.XML.HXT.DOM.TypeDefs

 
 data Interpreter
     = InlineCommandInterpreter {
 
 data Interpreter
     = InlineCommandInterpreter {

-        iciName      :: !String
-      , iciInterpret :: !(InterpreterContext -> InlineCommand -> IO InlineElement)
+        iciName      ∷ !Text
+      , iciInterpret ∷ !(InterpreterContext → InlineCommand → IO InlineElement)

       }
     | BlockCommandInterpreter {
       }
     | BlockCommandInterpreter {

-        bciName      :: !String
-      , bciInterpret :: !(InterpreterContext -> BlockCommand -> IO BlockElement)
+        bciName      ∷ !Text
+      , bciInterpret ∷ !(InterpreterContext → BlockCommand → IO BlockElement)

       }
 
 
       }
 
 


@@ -35,12 +37,10 @@ data InterpreterContext
       , ctxSysConf    :: !SystemConfig
       }
 
       , ctxSysConf    :: !SystemConfig
       }
 

-
-commandName :: Interpreter -> String
+commandName ∷ Interpreter → Text

 commandName (InlineCommandInterpreter name _) = name
 commandName (BlockCommandInterpreter  name _) = name
 
 commandName (InlineCommandInterpreter name _) = name
 commandName (BlockCommandInterpreter  name _) = name
 

-
-commandType :: Interpreter -> CommandType
+commandType ∷ Interpreter → CommandType

 commandType (InlineCommandInterpreter _ _) = InlineCommandType
 commandType (BlockCommandInterpreter  _ _) = BlockCommandType
 commandType (InlineCommandInterpreter _ _) = InlineCommandType
 commandType (BlockCommandInterpreter  _ _) = BlockCommandType

diff --git a/Rakka/Wiki/Interpreter/Base.hs b/Rakka/Wiki/Interpreter/Base.hs
index ed81494e62e4c671e13d4f2ba682251752ce8904..73950537c9bd7179b26655f0f38531df69201de4 100644 (file)
--- a/Rakka/Wiki/Interpreter/Base.hs
+++ b/Rakka/Wiki/Interpreter/Base.hs
@@ -1,20 +1,31 @@
+{-# LANGUAGE
+    OverloadedStrings
+  , RecordWildCards
+  , UnicodeSyntax
+  #-}

 module Rakka.Wiki.Interpreter.Base
     ( interpreters
     )
     where
 module Rakka.Wiki.Interpreter.Base
     ( interpreters
     )
     where

-
-import           Data.Map (Map)
+import Control.Applicative
+import Control.Arrow
+import Control.Arrow.ListArrow
+import Control.Arrow.Unicode
+import qualified Data.CaseInsensitive as CI
+import Data.Map (Map)

 import qualified Data.Map as M
 import qualified Data.Map as M

-import           Data.Maybe
-import           Rakka.Page
-import           Rakka.SystemConfig
-import           Rakka.Wiki
-import           Rakka.Wiki.Interpreter
-import           Text.XML.HXT.Arrow
-import           Text.XML.HXT.XPath
-
-
-interpreters :: [Interpreter]
+import Data.Maybe
+import Data.Monoid.Unicode
+import qualified Data.Text as T
+import Prelude.Unicode
+import Rakka.Page
+import Rakka.SystemConfig
+import Rakka.Wiki
+import Rakka.Wiki.Interpreter
+import Text.XML.HXT.Arrow.XmlArrow
+import Text.XML.HXT.XPath
+
+interpreters ∷ [Interpreter]

 interpreters = [ lineBreakInterp
                , spanInterp
                , divInterp
 interpreters = [ lineBreakInterp
                , spanInterp
                , divInterp


@@ -27,7 +38,6 @@ interpreters = [ lineBreakInterp
                , configurationInterp
                ]
 
                , configurationInterp
                ]
 

-

 lineBreakInterp :: Interpreter
 lineBreakInterp = InlineCommandInterpreter {
                     iciName = "br"
 lineBreakInterp :: Interpreter
 lineBreakInterp = InlineCommandInterpreter {
                     iciName = "br"


@@ -60,43 +70,44 @@ pageNameInterp = InlineCommandInterpreter {
                      = \ ctx _ -> return $ Text (fromMaybe "" $ ctxPageName ctx)
                  }
 
                      = \ ctx _ -> return $ Text (fromMaybe "" $ ctxPageName ctx)
                  }
 

-
-otherLangsInterp :: Interpreter
+otherLangsInterp ∷ Interpreter

 otherLangsInterp
     = BlockCommandInterpreter {
         bciName = "inOtherLanguages"
       , bciInterpret
 otherLangsInterp
     = BlockCommandInterpreter {
         bciName = "inOtherLanguages"
       , bciInterpret

-          = \ ctx _ ->
-            let linkTable = case ctxMainPage ctx of
-                              Just page -> runLA ( getXPathTreesInDoc "/page/otherLang/link"
-                                                   >>>
-                                                   ( getAttrValue0 "lang"
-                                                     &&&
-                                                     getAttrValue0 "page"
-                                                   )
-                                                 ) page
-                              Nothing   -> []
+          = \(InterpreterContext {..}) _ →
+            let linkTable = case ctxMainPage of
+                              Just page → runLA ( getXPathTreesInDoc "/page/otherLang/link"
+                                                  ⋙
+                                                  ( getAttrValue0 "lang"
+                                                    &&&
+                                                    getAttrValue0 "page"
+                                                  )
+                                                ) page
+                              Nothing   → []

             in
               case linkTable of
                 [] -> return EmptyBlock
             in
               case linkTable of
                 [] -> return EmptyBlock

-                _  -> do Languages langTable <- getSysConf (ctxSysConf ctx)
-                         let merged = mergeTables langTable linkTable
-                         return $ mkLangList merged
+                _  -> do Languages langTable ← getSysConf ctxSysConf
+                         let merged = mergeTables langTable $
+                                      (CI.mk ∘ T.pack ⁂ T.pack) <$> linkTable
+                         pure $ mkLangList merged

       }
     where
       }
     where

-      mergeTables :: Map LanguageTag LanguageName
-                  -> [(LanguageTag, PageName)]
-                  -> [(LanguageName, PageName)]
+      mergeTables ∷ Map LanguageTag LanguageName
+                  → [(LanguageTag, PageName)]
+                  → [(LanguageName, PageName)]

       mergeTables _ []     = []
       mergeTables m (x:xs) = let (langTag, name) = x
       mergeTables _ []     = []
       mergeTables m (x:xs) = let (langTag, name) = x

-                                 langName        = fromMaybe langTag (M.lookup langTag m)
+                                 langName        = fromMaybe (CI.foldedCase langTag)
+                                                             (M.lookup langTag m)

                              in
                                (langName, name) : mergeTables m xs
 
                              in
                                (langName, name) : mergeTables m xs
 

-      mkLangList :: [(LanguageName, PageName)] -> BlockElement
-      mkLangList = List Bullet . map mkLangLink
+      mkLangList ∷ [(LanguageName, PageName)] → BlockElement
+      mkLangList = List Bullet ∘ (mkLangLink <$>)

 
 

-      mkLangLink :: (LanguageName, PageName) -> ListItem
+      mkLangLink ∷ (LanguageName, PageName) → ListItem

       mkLangLink (langName, name)
           = [Inline (PageLink (Just name) Nothing (Just langName))]
 
       mkLangLink (langName, name)
           = [Inline (PageLink (Just name) Nothing (Just langName))]
 


@@ -126,17 +137,17 @@ newPageInterp
 --        value="Edit"
 --        onclick="Rakka.editPage(\"Foo\")"
 --        class="editButton controls" />
 --        value="Edit"
 --        onclick="Rakka.editPage(\"Foo\")"
 --        class="editButton controls" />

-editPageInterp :: Interpreter
+editPageInterp ∷ Interpreter

 editPageInterp 
     = InlineCommandInterpreter {
         iciName = "editPage"
       , iciInterpret
 editPageInterp 
     = InlineCommandInterpreter {
         iciName = "editPage"
       , iciInterpret

-          = \ ctx (InlineCommand _ args _) ->
+          = \ctx (InlineCommand _ args _) →

             let name  = fromMaybe (fromMaybe "" $ ctxPageName ctx) (lookup "page" args)
                 label = fromMaybe "Edit this page" (lookup "label" args)
                 attrs = [ ("type"   , "button")
                         , ("value"  , label)
             let name  = fromMaybe (fromMaybe "" $ ctxPageName ctx) (lookup "page" args)
                 label = fromMaybe "Edit this page" (lookup "label" args)
                 attrs = [ ("type"   , "button")
                         , ("value"  , label)

-                        , ("onclick", "Rakka.editPage(\"" ++ name ++ "\")")
+                        , ("onclick", "Rakka.editPage(\"" ⊕ name ⊕ "\")")

                         , ("class"  , "editButton controls")
                         ]
             in
                         , ("class"  , "editButton controls")
                         ]
             in


@@ -180,12 +191,12 @@ searchFieldInterp
 -- <input type="button"
 --        value="Configuration"
 --        class="configButton controls" />
 -- <input type="button"
 --        value="Configuration"
 --        class="configButton controls" />

-configurationInterp :: Interpreter
+configurationInterp ∷ Interpreter

 configurationInterp 
     = InlineCommandInterpreter {
         iciName = "configuration"
       , iciInterpret
 configurationInterp 
     = InlineCommandInterpreter {
         iciName = "configuration"
       , iciInterpret

-          = \ _ _ ->
+          = \_ _ →

             let attrs = [ ("type" , "button")
                         , ("value", "Configuration")
                         , ("class", "configButton controls")
             let attrs = [ ("type" , "button")
                         , ("value", "Configuration")
                         , ("class", "configButton controls")

diff --git a/Rakka/Wiki/Interpreter/Image.hs b/Rakka/Wiki/Interpreter/Image.hs
index 00a55de056191ae9fb53b6713907bd2b75bc1b23..886fdf512732228f1f746b7481d81bf0987b4c07 100644 (file)
--- a/Rakka/Wiki/Interpreter/Image.hs
+++ b/Rakka/Wiki/Interpreter/Image.hs
@@ -1,21 +1,28 @@
+{-# LANGUAGE
+    OverloadedStrings
+  , RecordWildCards
+  , UnicodeSyntax
+  , ViewPatterns
+  #-}

 module Rakka.Wiki.Interpreter.Image
     ( interpreters
     )
     where
 module Rakka.Wiki.Interpreter.Image
     ( interpreters
     )
     where

+import Data.Monoid.Unicode
+import Data.Text (Text)
+import qualified Data.Text as T
+import Network.URI
+import Prelude.Unicode
+import Rakka.Page
+import Rakka.SystemConfig
+import Rakka.Wiki.Interpreter
+import Rakka.Wiki

 
 

-import           Network.URI
-import           Rakka.Page
-import           Rakka.SystemConfig
-import           Rakka.Wiki.Interpreter
-import           Rakka.Wiki
-
-
-interpreters :: [Interpreter]
+interpreters ∷ [Interpreter]

 interpreters = [ imageInterp
                , imgFrameInterp
                ]
 
 interpreters = [ imageInterp
                , imgFrameInterp
                ]
 

-

 -- <img src="[PageName]"
 --      alt="[Alternative]"   -- 省略可能
 --      link="[PageName]"     -- 省略可能、省略時は画像そのものへのリンク
 -- <img src="[PageName]"
 --      alt="[Alternative]"   -- 省略可能
 --      link="[PageName]"     -- 省略可能、省略時は画像そのものへのリンク


@@ -25,34 +32,32 @@ interpreters = [ imageInterp
 -- <a href="..." class="inlineImage ...">
 --   <img src="..." alt="..." />
 -- </a>
 -- <a href="..." class="inlineImage ...">
 --   <img src="..." alt="..." />
 -- </a>

-imageInterp :: Interpreter
+imageInterp ∷ Interpreter

 imageInterp
     = InlineCommandInterpreter {
 imageInterp
     = InlineCommandInterpreter {

-        iciName      = "img"
+        iciName = "img"

       , iciInterpret
       , iciInterpret

-          = \ ctx (InlineCommand _ attrs _) ->
-            do BaseURI baseURI <- getSysConf (ctxSysConf ctx)
-
+          = \(InterpreterContext {..}) (InlineCommand _ attrs _) →
+            do BaseURI baseURI ← getSysConf ctxSysConf

                let name        = case lookup "src" attrs of
                let name        = case lookup "src" attrs of

-                                   Just x  -> x
-                                   Nothing -> error "\"src\" attribute is missing"
+                                   Just x  → x
+                                   Nothing → error "\"src\" attribute is missing"

                    link        = case lookup "link" attrs of
                    link        = case lookup "link" attrs of

-                                   Just "" -> Nothing
-                                   Just x  -> if isURI x then
-                                                  Just x
-                                              else
-                                                  Just (uriToString id (mkPageURI baseURI x) "")
-                                   Nothing -> Just (uriToString id (mkPageURI baseURI name) "")
+                                   Just x
+                                       | T.null x  → Nothing
+                                       | isURI' x  → Just x
+                                       | otherwise → Just ∘ T.pack $ uriToString id (mkPageURI baseURI x   ) ""
+                                   Nothing         → Just ∘ T.pack $ uriToString id (mkPageURI baseURI name) ""

                    alt         = lookup "alt" attrs
                    classAttr   = case lookup "float" attrs of
                    alt         = lookup "alt" attrs
                    classAttr   = case lookup "float" attrs of

-                                   Nothing      -> "inlineImage"
-                                   Just "left"  -> "inlineImage leftFloat"
-                                   Just "right" -> "inlineImage rightFloat"
-                                   Just others  -> error ("unknown \"float\" attribute: " ++ others)
+                                   Nothing      → "inlineImage"
+                                   Just "left"  → "inlineImage leftFloat"
+                                   Just "right" → "inlineImage rightFloat"
+                                   Just others  → error ("unknown \"float\" attribute: " ⊕ T.unpack others)

                    result      = case link of
                    result      = case link of

-                                   Nothing -> Span [("class", classAttr)] [Image (Right name) alt]
-                                   Just x  -> Anchor [ ("class", classAttr)
-                                                     , ("href" , x        ) ] [Image (Right name) alt]
+                                   Nothing → Span [("class", classAttr)] [Image (Right name) alt]
+                                   Just x  → Anchor [ ("class", classAttr)
+                                                    , ("href" , x        ) ] [Image (Right name) alt]

                return result
       }
 
                return result
       }
 


@@ -67,38 +72,39 @@ imageInterp
 --     ...
 --   </div>
 -- </div>
 --     ...
 --   </div>
 -- </div>

-imgFrameInterp :: Interpreter
+imgFrameInterp ∷ Interpreter

 imgFrameInterp
     = BlockCommandInterpreter {
 imgFrameInterp
     = BlockCommandInterpreter {

-        bciName      = "imgframe"
+        bciName = "imgframe"

       , bciInterpret
       , bciInterpret

-          = \ ctx (BlockCommand _ attrs inside) ->
-            do BaseURI baseURI <- getSysConf (ctxSysConf ctx)
-
+          = \(InterpreterContext {..}) (BlockCommand _ attrs inside) →
+            do BaseURI baseURI ← getSysConf ctxSysConf

                let name        = case lookup "src" attrs of
                let name        = case lookup "src" attrs of

-                                   Just x  -> x
-                                   Nothing -> error "\"src\" attribute is missing"
+                                   Just x  → x
+                                   Nothing → error "\"src\" attribute is missing"

                    link        = case lookup "link" attrs of
                    link        = case lookup "link" attrs of

-                                   Just "" -> Nothing
-                                   Just x  -> if isURI x then
-                                                  Just x
-                                              else
-                                                  Just (uriToString id (mkPageURI baseURI x) "")
-                                   Nothing -> Just (uriToString id (mkPageURI baseURI name) "")
+                                   Just x
+                                       | T.null x  → Nothing
+                                       | isURI' x  → Just x
+                                       | otherwise → Just ∘ T.pack $ uriToString id (mkPageURI baseURI x   ) ""
+                                   Nothing         → Just ∘ T.pack $ uriToString id (mkPageURI baseURI name) ""

                    classAttr   = case lookup "float" attrs of
                    classAttr   = case lookup "float" attrs of

-                                   Nothing      -> ("class", "imageFrame")
-                                   Just "left"  -> ("class", "imageFrame leftFloat")
-                                   Just "right" -> ("class", "imageFrame rightFloat")
-                                   Just others  -> error ("unknown \"float\" attribute: " ++ others)
+                                   Nothing      → ("class", "imageFrame")
+                                   Just "left"  → ("class", "imageFrame leftFloat")
+                                   Just "right" → ("class", "imageFrame rightFloat")
+                                   Just others  → error ("unknown \"float\" attribute: " ⊕ T.unpack others)

                    image       = case link of
                    image       = case link of

-                                   Nothing -> Image (Right name) Nothing
-                                   Just x  -> Anchor [("href" , x)] [Image (Right name) Nothing]
+                                   Nothing → Image (Right name) Nothing
+                                   Just x  → Anchor [("href" , x)] [Image (Right name) Nothing]

                
                return (Div [classAttr]
                        [ Block (Div [("class", "imageData")]
                                         [ Inline image ])
                        , Block (Div [("class", "imageCaption")]
                
                return (Div [classAttr]
                        [ Block (Div [("class", "imageData")]
                                         [ Inline image ])
                        , Block (Div [("class", "imageCaption")]

-                                        [ Block x | x <- inside ])
+                                        [ Block x | x ← inside ])

                        ]
                       )
       }
                        ]
                       )
       }

+
+isURI' ∷ Text → Bool
+isURI' = isURI ∘ T.unpack
\ No newline at end of file

diff --git a/Rakka/Wiki/Interpreter/Outline.hs b/Rakka/Wiki/Interpreter/Outline.hs
index 983b4597cbb5d20d84c8bb878f2231bc0bf6b710..3c66db1d90b6913032d20b30bf8c34a931529a3b 100644 (file)
--- a/Rakka/Wiki/Interpreter/Outline.hs
+++ b/Rakka/Wiki/Interpreter/Outline.hs
@@ -1,12 +1,14 @@
+{-# LANGUAGE
+    OverloadedStrings
+  , UnicodeSyntax
+  #-}

 module Rakka.Wiki.Interpreter.Outline
     ( interpreters
     )
     where
 module Rakka.Wiki.Interpreter.Outline
     ( interpreters
     )
     where

-
-import           Data.Maybe
-import           Rakka.Wiki
-import           Rakka.Wiki.Interpreter
-
+import Data.Maybe
+import Rakka.Wiki
+import Rakka.Wiki.Interpreter

 
 interpreters :: [Interpreter]
 interpreters = [ outlineInterp ]
 
 interpreters :: [Interpreter]
 interpreters = [ outlineInterp ]

diff --git a/Rakka/Wiki/Interpreter/PageList.hs b/Rakka/Wiki/Interpreter/PageList.hs
index 3d5ce246b5e511f7de4f1f6623f54c0eb994cdee..d94f67ea1545a597b511c8f116e8fac5ebe37c44 100644 (file)
--- a/Rakka/Wiki/Interpreter/PageList.hs
+++ b/Rakka/Wiki/Interpreter/PageList.hs
@@ -1,13 +1,21 @@
+{-# LANGUAGE
+    OverloadedStrings
+  , RecordWildCards
+  , UnicodeSyntax
+  #-}

 module Rakka.Wiki.Interpreter.PageList
     ( interpreters
     )
     where
 module Rakka.Wiki.Interpreter.PageList
     ( interpreters
     )
     where

-
-import           Control.Monad
-import           Data.Maybe
+import Control.Applicative
+import Control.Monad
+import Data.Maybe
+import Data.Monoid.Unicode
+import qualified Data.Text as T

 import           Data.Time
 import           Data.Time

-import           Network.HTTP.Lucu.RFC1123DateTime
+import qualified Data.Time.RFC1123 as RFC1123

 import           Network.URI
 import           Network.URI

+import Prelude.Unicode

 import           Rakka.Storage
 import           Rakka.SystemConfig
 import           Rakka.Utils
 import           Rakka.Storage
 import           Rakka.SystemConfig
 import           Rakka.Utils


@@ -51,29 +59,26 @@ recentUpdatesURLInterp
 --     ...
 --   </ul>
 -- </div>
 --     ...
 --   </ul>
 -- </div>

-recentUpdatesInterp :: Interpreter
+recentUpdatesInterp ∷ Interpreter

 recentUpdatesInterp 
     = BlockCommandInterpreter {
         bciName      = "recentUpdates"
       , bciInterpret
 recentUpdatesInterp 
     = BlockCommandInterpreter {
         bciName      = "recentUpdates"
       , bciInterpret

-          = \ ctx (BlockCommand _ args _)
-          -> do let items          = fromMaybe 10   $ fmap read         $ lookup "items" args
-                    showSummary    = fromMaybe True $ fmap parseYesOrNo $ lookup "showSummary" args
-                    onlyEntity     = fromMaybe True $ fmap parseYesOrNo $ lookup "onlyEntity" args
-                    onlySummarized = fromMaybe True $ fmap parseYesOrNo $ lookup "onlySummarized" args
-                    sto            = ctxStorage ctx
-                
-                cond <- newCondition
-                when onlyEntity
-                    $ addAttrCond cond "@type STRNE application/x-rakka-redirection"
-                when onlySummarized
-                    $ addAttrCond cond "rakka:summary STRNE" -- summary が空でない
-                setPhrase cond "[UVSET]"
-                setOrder  cond "@mdate NUMD"
-                setMax    cond items
-
-                result <- searchPages sto cond
-                mkPageList showSummary (srPages result)
+          = \(InterpreterContext {..}) (BlockCommand _ args _) →
+            do let items          = fromMaybe 10   $ read ∘ T.unpack <$> lookup "items" args
+                   showSummary    = fromMaybe True $ parseYesOrNo    <$> lookup "showSummary" args
+                   onlyEntity     = fromMaybe True $ parseYesOrNo    <$> lookup "onlyEntity" args
+                   onlySummarized = fromMaybe True $ parseYesOrNo    <$> lookup "onlySummarized" args
+               cond ← newCondition
+               when onlyEntity
+                   $ addAttrCond cond "@type STRNE application/x-rakka-redirection"
+               when onlySummarized
+                   $ addAttrCond cond "rakka:summary STRNE" -- summary が空でない
+               setPhrase cond "[UVSET]"
+               setOrder  cond "@mdate NUMD"
+               setMax    cond items
+               result ← searchPages ctxStorage cond
+               mkPageList showSummary (srPages result)

       }
     where
       mkPageList :: Bool -> [HitPage] -> IO BlockElement
       }
     where
       mkPageList :: Bool -> [HitPage] -> IO BlockElement


@@ -82,21 +87,21 @@ recentUpdatesInterp
                return (Div [("class", "recentUpdates")]
                        [ Block (List Bullet items) ])
 
                return (Div [("class", "recentUpdates")]
                        [ Block (List Bullet items) ])
 

-      mkListItem :: Bool -> HitPage -> IO ListItem
+      mkListItem ∷ Bool → HitPage → IO ListItem

       mkListItem showSummary page
       mkListItem showSummary page

-          = do lastMod <- utcToLocalZonedTime (hpLastMod page)
+          = do lastMod ← utcToLocalZonedTime (hpLastMod page)

                return ( [ Inline PageLink {
                                        linkPage     = Just (hpPageName page)
                                      , linkFragment = Nothing
                                      , linkText     = Nothing
                                      }
                         , Block ( Div [("class", "date")]
                return ( [ Inline PageLink {
                                        linkPage     = Just (hpPageName page)
                                      , linkFragment = Nothing
                                      , linkText     = Nothing
                                      }
                         , Block ( Div [("class", "date")]

-                                  [Inline (Text (formatRFC1123DateTime lastMod))]
+                                  [Inline (Text (T.pack $ RFC1123.format lastMod))]

                                 )
                         ]
                                 )
                         ]

-                        ++
+                        ⊕

                         case (showSummary, hpSummary page) of
                           (True, Just s)
                         case (showSummary, hpSummary page) of
                           (True, Just s)

-                              -> [ Block (Paragraph [Text s]) ]
-                          _   -> []
+                              → [ Block (Paragraph [Text s]) ]
+                          _   → []

                       )
                       )

diff --git a/Rakka/Wiki/Parser.hs b/Rakka/Wiki/Parser.hs
index 1744570b1bd5a27d805523ff9252cdc8eaece0fc..3b3d7c401260b1efe09ec2901f9c6d2885bb2d58 100644 (file)
--- a/Rakka/Wiki/Parser.hs
+++ b/Rakka/Wiki/Parser.hs
@@ -1,18 +1,30 @@
+{-# LANGUAGE
+    OverloadedStrings
+  , RankNTypes
+  , UnicodeSyntax
+  , ViewPatterns
+  #-}

 module Rakka.Wiki.Parser
     ( CommandTypeOf
     , wikiPage
     )
     where
 module Rakka.Wiki.Parser
     ( CommandTypeOf
     , wikiPage
     )
     where

-
-import           Control.Monad
-import           Data.Maybe
-import           Network.URI hiding (fragment)
-import           Rakka.Wiki
-import           Text.ParserCombinators.Parsec hiding (label)
-
-
-type CommandTypeOf = String -> Maybe CommandType
-
+-- FIXME: use attoparsec
+import Control.Applicative hiding ((<|>), many)
+import Control.Applicative.Unicode
+import Control.Monad
+import Data.CaseInsensitive (CI)
+import qualified Data.CaseInsensitive as CI
+import Data.Maybe
+import Data.Monoid.Unicode ((⊕))
+import Data.Text (Text)
+import qualified Data.Text as T
+import Network.URI hiding (fragment)
+import Prelude.Unicode
+import Rakka.Wiki
+import Text.ParserCombinators.Parsec hiding (label)
+
+type CommandTypeOf = Alternative f ⇒ Text → f CommandType

 
 wikiPage :: CommandTypeOf -> Parser WikiPage
 wikiPage cmdTypeOf
 
 wikiPage :: CommandTypeOf -> Parser WikiPage
 wikiPage cmdTypeOf


@@ -41,26 +53,25 @@ blockElement cmdTypeOf
                                  , blockCmd cmdTypeOf
                                  ]
 
                                  , blockCmd cmdTypeOf
                                  ]
 

-
-heading :: Parser BlockElement
+heading ∷ Parser BlockElement

 heading = foldr (<|>) pzero (map heading' [1..5])
           <?>
           "heading"
     where
 heading = foldr (<|>) pzero (map heading' [1..5])
           <?>
           "heading"
     where

-      heading' :: Int -> Parser BlockElement
-      heading' n = do try $ do _ <- count n (char '=')
-                               notFollowedBy (char '=')
+      heading' ∷ Int → Parser BlockElement
+      heading' n = do try ( void (count n (char '=')) *>
+                            notFollowedBy (char '=')
+                          )

                       ws
                       ws

-                      x  <- notFollowedBy (char '=') >> anyChar
-                      xs <- manyTill anyChar (try $ ws >> ( count n (char '=')
-                                                            <?>
-                                                            ("trailing " ++ replicate n '=')
-                                                          )
-                                             )
+                      x  ← notFollowedBy (char '=') *> anyChar
+                      xs ← manyTill anyChar (try $ ws *> ( count n (char '=')
+                                                           <?>
+                                                           ("trailing " ++ replicate n '=')
+                                                         )
+                                            )

                       ws
                       eol
                       ws
                       eol

-                      return (Heading n (x:xs))
-
+                      pure ∘ Heading n $ T.pack (x:xs)

 
 horizontalLine :: Parser BlockElement
 horizontalLine = try ( do _ <- count 4 (char '-')
 
 horizontalLine :: Parser BlockElement
 horizontalLine = try ( do _ <- count 4 (char '-')


@@ -151,19 +162,15 @@ definitionList cmdTypeOf = liftM DefinitionList (many1 definition)
                     "description of term"
 
 
                     "description of term"
 
 

-verbatim :: Parser BlockElement
-verbatim = do _ <- try (string "<!verbatim[")
-              _ <- many (oneOf " \t\n")
-              x <- verbatim'
-              return (Preformatted [Text x])
+verbatim ∷ Parser BlockElement
+verbatim = try (string "<!verbatim[") *>
+           many (oneOf " \t\n")       *>
+           (Preformatted ∘ (:[]) ∘ Text ∘ T.pack <$> verbatim')

     where
       verbatim' :: Parser String
     where
       verbatim' :: Parser String

-      verbatim' = do _ <- try (many (oneOf " \t\n") >> string "]>")
-                     return []
+      verbatim' = try (many (oneOf " \t\n") *> string "]>") *> pure []

                   <|>
                   <|>

-                  do x  <- anyChar
-                     xs <- verbatim'
-                     return (x:xs)
+                  ((:) <$> anyChar ⊛ verbatim')

 
 
 leadingSpaced :: CommandTypeOf -> Parser BlockElement
 
 
 leadingSpaced :: CommandTypeOf -> Parser BlockElement


@@ -235,10 +242,8 @@ blockCmd cmdTypeOf
                                        , bCmdAttributes = tagAttrs
                                        , bCmdContents   = xs
                                        }
                                        , bCmdAttributes = tagAttrs
                                        , bCmdContents   = xs
                                        }

-

                   Just InlineCommandType
                       -> pzero
                   Just InlineCommandType
                       -> pzero

-

                   _   -> return $ undefinedCmdErr tagName
       )
       <|>
                   _   -> return $ undefinedCmdErr tagName
       )
       <|>


@@ -250,35 +255,30 @@ blockCmd cmdTypeOf
                                        , bCmdAttributes = tagAttrs
                                        , bCmdContents   = []
                                        }
                                        , bCmdAttributes = tagAttrs
                                        , bCmdContents   = []
                                        }

-

                   Just InlineCommandType
                       -> pzero
                   Just InlineCommandType
                       -> pzero

-

                   _   -> return $ undefinedCmdErr tagName
       )
       <?>
       "block command"
     where
                   _   -> return $ undefinedCmdErr tagName
       )
       <?>
       "block command"
     where

-      contents :: Parser [BlockElement]
-      contents = do x  <- blockElement cmdTypeOf
-                    xs <- contents
-                    return (x:xs)
+      contents ∷ Parser [BlockElement]
+      contents = ((:) <$> blockElement cmdTypeOf ⊛ contents)

                  <|>
                  <|>

-                 (newline >> contents)
+                 (newline *> contents)

                  <|>
                  <|>

-                 (comment >> contents)
+                 (comment *> contents)

                  <|>
                  <|>

-                 return []
+                 pure []

 
 

-      undefinedCmdErr :: String -> BlockElement
+      undefinedCmdErr ∷ Text → BlockElement

       undefinedCmdErr name
           = Div [("class", "error")]
       undefinedCmdErr name
           = Div [("class", "error")]

-            [ Block (Paragraph [Text ("The command `" ++ name ++ "' is not defined. " ++
+            [ Block (Paragraph [Text ("The command `" ⊕ name ⊕ "' is not defined. " ⊕

                                       "Make sure you haven't mistyped.")
                                ])
             ]
 
                                       "Make sure you haven't mistyped.")
                                ])
             ]
 

-

 inlineElement :: CommandTypeOf -> Parser InlineElement
 inlineElement cmdTypeOf
     = try $ do skipMany comment
 inlineElement :: CommandTypeOf -> Parser InlineElement
 inlineElement cmdTypeOf
     = try $ do skipMany comment


@@ -291,31 +291,24 @@ inlineElement cmdTypeOf
                                  , inlineCmd cmdTypeOf
                                  ]
 
                                  , inlineCmd cmdTypeOf
                                  ]
 

-
-nowiki :: Parser InlineElement
-nowiki = liftM Text (try (string "<!nowiki[") >> nowiki')
+nowiki ∷ Parser InlineElement
+nowiki = Text ∘ T.pack <$> (try (string "<!nowiki[") *> nowiki')

     where
     where

-      nowiki' :: Parser String
-      nowiki' = do _ <- try (string "]>")
-                   return []
+      nowiki' ∷ Parser String
+      nowiki' = (try (string "]>") *> pure [])

                 <|>
                 <|>

-                do x  <- anyChar
-                   xs <- nowiki'
-                   return (x:xs)
+                ((:) <$> anyChar ⊛ nowiki')

 
 

-
-text :: Parser InlineElement
-text = liftM (Text . (':' :)) ( char ':'
-                                >>
-                                many (noneOf ('\n':inlineSymbols))
-                              )
+text ∷ Parser InlineElement
+text = (Text ∘ T.pack ∘ (':' :) <$> ( char ':' *>
+                                      many (noneOf ('\n':inlineSymbols))
+                                    ))

        -- 定義リストとの關係上、コロンは先頭にしか來られない。
        <|>
        -- 定義リストとの關係上、コロンは先頭にしか來られない。
        <|>

-       liftM Text (many1 (noneOf ('\n':inlineSymbols)))
+       (Text ∘ T.pack <$> (many1 (noneOf ('\n':inlineSymbols))))

        <?>
        "text"
 
        <?>
        "text"
 

-

 apostrophes :: CommandTypeOf -> Parser InlineElement
 apostrophes cmdTypeOf = foldr (<|>) pzero (map try [apos1, apos2, apos3, apos4, apos5])
     where
 apostrophes :: CommandTypeOf -> Parser InlineElement
 apostrophes cmdTypeOf = foldr (<|>) pzero (map try [apos1, apos2, apos3, apos4, apos5])
     where


@@ -342,63 +335,57 @@ apostrophes cmdTypeOf = foldr (<|>) pzero (map try [apos1, apos2, apos3, apos4,
       apos n = count n (char '\'') >> notFollowedBy (char '\'')
 
 
       apos n = count n (char '\'') >> notFollowedBy (char '\'')
 
 

-objLink :: Parser InlineElement
-objLink = do _     <- try (string "[[[")
-             page  <- many1 (noneOf "|]")
-             label <- option Nothing
-                      (liftM Just (char '|' >> many1 (satisfy (/= ']'))))
-             _     <- string "]]]"
-             return $ ObjectLink page label
+objLink ∷ Parser InlineElement
+objLink = do void $ try (string "[[[")
+             page  ← many1 (noneOf "|]")
+             label ← option Nothing $
+                     Just <$> (char '|' *> many1 (satisfy (≠ ']')))
+             void $ string "]]]"
+             pure $ ObjectLink (T.pack page) (T.pack <$> label)

           <?>
           "object link"
 
           <?>
           "object link"
 

-
-pageLink :: Parser InlineElement
-pageLink = do _        <- try (string "[[")
-              page     <- option Nothing 
-                          (liftM Just (many1 (noneOf "#|]")))
-              fragment <- option Nothing
-                          (liftM Just (char '#' >> many1 (noneOf "|]")))
-              label    <- option Nothing
-                          (liftM Just (char '|' >> many1 (satisfy (/= ']'))))
-
-              case (page, fragment) of
-                (Nothing, Nothing) -> pzero
-                (_, _)             -> return ()
-
-              _ <- string "]]"
-              return $ PageLink page fragment label
+pageLink ∷ Parser InlineElement
+pageLink = do void $ try (string "[[")
+              page     ← option Nothing $
+                         Just <$> many1 (noneOf "#|]")
+              fragment ← option Nothing $
+                         Just <$> (char '#' *> many1 (noneOf "|]"))
+              label    ← option Nothing $
+                         Just <$> (char '|' *> many1 (satisfy (≠ ']')))
+              when (isNothing page ∧ isNothing fragment) (∅)
+              void $ string "]]"
+              pure $ PageLink (T.pack <$> page    )
+                              (T.pack <$> fragment)
+                              (T.pack <$> label   )

            <?>
            "page link"
 
            <?>
            "page link"
 

-
-extLink :: Parser InlineElement
-extLink = do _      <- char '['
-             uriStr <- many1 (noneOf " \t]")
-             _      <- skipMany (oneOf " \t")
-             label  <- option Nothing
-                       (liftM Just (many1 (noneOf "]")))
-             
+extLink ∷ Parser InlineElement
+extLink = do void $ char '['
+             uriStr ← many1 (noneOf " \t]")
+             void $ skipMany (oneOf " \t")
+             label ← option Nothing $
+                     Just <$> many1 (noneOf "]")

              case parseURI uriStr of
              case parseURI uriStr of

-               Just uri -> char ']' >> return (ExternalLink uri label)
-               Nothing  -> pzero <?> "absolute URI"
+               Just uri → char ']' *> pure (ExternalLink uri (T.pack <$> label))
+               Nothing  → pzero <?> "absolute URI"

           <?>
           "external link"
 
           <?>
           "external link"
 

-
-inlineCmd :: CommandTypeOf -> Parser InlineElement
+inlineCmd ∷ CommandTypeOf → Parser InlineElement

 inlineCmd cmdTypeOf
 inlineCmd cmdTypeOf

-    = (try $ do (tagName, tagAttrs) <- openTag
+    = (try $ do (tagName, tagAttrs) ← openTag

                 case cmdTypeOf tagName of
                   Just InlineCommandType
                 case cmdTypeOf tagName of
                   Just InlineCommandType

-                      -> do xs <- contents
-                            closeTag tagName
-                            return $ InlineCmd InlineCommand {
+                      → do xs ← contents
+                           closeTag tagName
+                           pure $ InlineCmd InlineCommand {

                                          iCmdName       = tagName
                                        , iCmdAttributes = tagAttrs
                                        , iCmdContents   = xs
                                        }
                                          iCmdName       = tagName
                                        , iCmdAttributes = tagAttrs
                                        , iCmdContents   = xs
                                        }

-                  _   -> pzero
+                  _   → pzero

       )
       <|>
       (try $ do (tagName, tagAttrs) <- emptyTag
       )
       <|>
       (try $ do (tagName, tagAttrs) <- emptyTag


@@ -414,62 +401,58 @@ inlineCmd cmdTypeOf
       <?>
       "inline command"
     where
       <?>
       "inline command"
     where

-      contents :: Parser [InlineElement]
-      contents = do x  <- inlineElement cmdTypeOf
-                    xs <- contents
-                    return (x:xs)
+      contents ∷ Parser [InlineElement]
+      contents = ((:) <$> inlineElement cmdTypeOf ⊛ contents)

                  <|>
                  <|>

-                 (comment >> contents)
+                 (comment *> contents)

                  <|>
                  <|>

-                 liftM (Text "\n" :) (newline >> contents)
+                 ((Text "\n" :) <$> (newline *> contents))

                  <|>
                  <|>

-                 return []
-
-
-openTag :: Parser (String, [Attribute])
-openTag = try $ do _     <- char '<'
-                   _     <- many space
-                   name  <- many1 letter
-                   _     <- many space
-                   attrs <- many $ do attr <- tagAttr
-                                      _    <- many space
-                                      return attr
-                   _     <- char '>'
-                   return (name, attrs)
-
-
-emptyTag :: Parser (String, [Attribute])
-emptyTag = try $ do _     <- char '<'
-                    _     <- many space
-                    name  <- many1 letter
-                    _     <- many space
-                    attrs <- many $ do attr <- tagAttr
-                                       _    <- many space
-                                       return attr
-                    _     <- char '/'
-                    _     <- many space
-                    _     <- char '>'
-                    return (name, attrs)
-
-
-closeTag :: String -> Parser ()
-closeTag name = try $ do _ <- char '<'
-                         _ <- many space
-                         _ <- char '/'
-                         _ <- many space
-                         _ <- string name
-                         _ <- many space
-                         _ <- char '>'
-                         return ()
-
-
-tagAttr :: Parser (String, String)
-tagAttr = do name  <- many1 letter
-             _     <- char '='
-             _     <- char '"'
-             value <- many (satisfy (/= '"'))
-             _     <- char '"'
-             return (name, value)
+                 pure []
+
+openTag ∷ Parser (Text, [Attribute])
+openTag = try $ do void $ char '<'
+                   void $ many space
+                   name ← many1 letter
+                   void $ many space
+                   attrs ← many $ do attr ← tagAttr
+                                     void $ many space
+                                     pure attr
+                   void $ char '>'
+                   return (T.pack name, attrs)
+
+emptyTag ∷ Parser (Text, [Attribute])
+emptyTag = try $ do void $ char '<'
+                    void $ many space
+                    name ← many1 letter
+                    void $ many space
+                    attrs ← many $ do attr ← tagAttr
+                                      void $ many space
+                                      pure attr
+                    void $ char '/'
+                    void $ many space
+                    void $ char '>'
+                    return (T.pack name, attrs)
+
+closeTag ∷ Text → Parser ()
+closeTag (T.unpack → name)
+    = try ( char '<'    *>
+            many space  *>
+            char '/'    *>
+            many space  *>
+            string name *>
+            many space  *>
+            char '>'    *>
+            pure ()
+          )
+
+tagAttr ∷ Parser (CI Text, Text)
+tagAttr = do name ← many1 letter
+             void $ char '='
+             void $ char '"'
+             value ← many (satisfy (≠ '"'))
+             void $ char '"'
+             return (CI.mk $ T.pack name, T.pack value)

 
 
 comment :: Parser ()
 
 
 comment :: Parser ()

diff --git a/tests/WikiParserTest.hs b/tests/WikiParserTest.hs
index 856707244b527a24356e048bd1c43f0e5211e3a1..d3ee81682c8eb5a21b1ea222779250e0f8a7dc52 100644 (file)
--- a/tests/WikiParserTest.hs
+++ b/tests/WikiParserTest.hs
@@ -1,30 +1,32 @@
+{-# LANGUAGE
+    OverloadedStrings
+  , UnicodeSyntax
+  #-}

 module WikiParserTest
     ( testData
     )
     where
 module WikiParserTest
     ( testData
     )
     where

-
+import Control.Applicative

 import           Data.Maybe
 import           Data.Maybe

+import Data.Text (Text)

 import           Network.URI
 import           Rakka.Wiki
 import           Rakka.Wiki.Parser
 import           Test.HUnit
 import           Text.ParserCombinators.Parsec
 
 import           Network.URI
 import           Rakka.Wiki
 import           Rakka.Wiki.Parser
 import           Test.HUnit
 import           Text.ParserCombinators.Parsec
 

+cmdTypeOf ∷ Alternative f ⇒ Text → f CommandType
+cmdTypeOf "br"   = pure InlineCommandType
+cmdTypeOf "i"    = pure InlineCommandType
+cmdTypeOf "b"    = pure InlineCommandType
+cmdTypeOf "span" = pure InlineCommandType
+cmdTypeOf "div"  = pure BlockCommandType
+cmdTypeOf _      = empty

 
 

-cmdTypeOf :: String -> Maybe CommandType
-cmdTypeOf "br"   = Just InlineCommandType
-cmdTypeOf "i"    = Just InlineCommandType
-cmdTypeOf "b"    = Just InlineCommandType
-cmdTypeOf "span" = Just InlineCommandType
-cmdTypeOf "div"  = Just BlockCommandType
-cmdTypeOf _      = Nothing
-
-
-parseWiki :: String -> Either String WikiPage
+parseWiki ∷ String → Either String WikiPage

 parseWiki src = case parse (wikiPage cmdTypeOf) "" src of
 parseWiki src = case parse (wikiPage cmdTypeOf) "" src of

-                  Left  err  -> Left (show err)
-                  Right page -> Right page
-
+                  Left  err  → Left (show err)
+                  Right page → Right page

 
 testData :: [Test]
 testData = [ (parseWiki ""
 
 testData :: [Test]
 testData = [ (parseWiki ""