From 42f51754dea02201aececaacbf194d714cd58aaf Mon Sep 17 00:00:00 2001 From: PHO Date: Wed, 15 Feb 2012 01:16:15 +0900 Subject: [PATCH] Resurrection from bitrot --- GNUmakefile | 2 +- Main.hs | 35 +- Rakka.cabal | 16 +- Rakka/Attachment.hs | 67 +- Rakka/Authorization.hs | 107 ++-- Rakka/Environment.hs | 59 +- Rakka/Page.hs | 151 ++--- Rakka/Resource.hs | 151 ++--- Rakka/Resource/Index.hs | 19 +- Rakka/Resource/Object.hs | 18 +- Rakka/Resource/PageEntity.hs | 945 +++++++++++++++-------------- Rakka/Resource/Render.hs | 73 +-- Rakka/Resource/Search.hs | 403 ++++++------ Rakka/Resource/SystemConfig.hs | 163 ++--- Rakka/Resource/TrackBack.hs | 2 +- Rakka/Resource/Users.hs | 140 +++-- Rakka/Storage/DefaultPage.hs | 112 ++-- Rakka/Storage/Impl.hs | 75 +-- Rakka/Storage/Repos.hs | 203 ++++--- Rakka/Storage/Types.hs | 30 +- Rakka/SystemConfig.hs | 220 +++---- Rakka/Utils.hs | 31 +- Rakka/Validation.hs | 73 +-- Rakka/W3CDateTime.hs | 2 +- Rakka/Wiki.hs | 79 ++- Rakka/Wiki/Engine.hs | 350 +++++------ Rakka/Wiki/Formatter.hs | 172 +++--- Rakka/Wiki/Interpreter.hs | 30 +- Rakka/Wiki/Interpreter/Base.hs | 91 +-- Rakka/Wiki/Interpreter/Image.hs | 104 ++-- Rakka/Wiki/Interpreter/Outline.hs | 12 +- Rakka/Wiki/Interpreter/PageList.hs | 63 +- Rakka/Wiki/Parser.hs | 297 +++++---- tests/WikiParserTest.hs | 30 +- 34 files changed, 2188 insertions(+), 2137 deletions(-) diff --git a/GNUmakefile b/GNUmakefile index 0e02010..734bf84 100644 --- a/GNUmakefile +++ b/GNUmakefile @@ -1,6 +1,6 @@ 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 diff --git a/Main.hs b/Main.hs index 430fdfc..cf4cf88 100644 --- 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 Network +import Network.Socket import Network.HTTP.Lucu import OpenSSL import Rakka.Environment @@ -40,7 +43,7 @@ logger = "Main" data CmdOpt - = OptPortNum PortNumber + = OptPortNum ServiceName | OptLSDir FilePath | OptUserName String | OptGroupName String @@ -51,8 +54,8 @@ data CmdOpt deriving (Eq, Show) -defaultPort :: PortNumber -defaultPort = toEnum 8080 +defaultPort ∷ ServiceName +defaultPort = "8080" defaultLocalStateDir :: FilePath defaultLocalStateDir = LOCALSTATEDIR -- replaced by CPP @@ -70,8 +73,8 @@ defaultLogLevel = NOTICE 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") @@ -143,7 +146,7 @@ main = withOpenSSL $ withSystemLock (lsdir "lock") $ withPidFile (lsdir "pid") $ do setupLogger opts - env <- setupEnv lsdir portNum + env ← setupEnv lsdir portNum rebuildIndexIfRequested env opts @@ -167,17 +170,15 @@ resTree env , (["users" ], resUsers env) ] - -getPortNum :: [CmdOpt] -> IO PortNumber +getPortNum ∷ [CmdOpt] → IO ServiceName 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 - [] -> 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 diff --git a/Rakka.cabal b/Rakka.cabal index 66117ce..6345b45 100644 --- a/Rakka.cabal +++ b/Rakka.cabal @@ -61,12 +61,20 @@ Flag build-test-suite 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 + Main-Is: Main.hs + Other-Modules: Rakka.Attachment Rakka.Authorization @@ -104,9 +112,7 @@ Executable rakka Rakka.Wiki.Engine Rakka.Wiki.Formatter Rakka.Wiki.Parser - Extensions: - Arrows, ExistentialQuantification, ScopedTypeVariables, - DeriveDataTypeable, FlexibleInstances + GHC-Options: -Wall -threaded @@ -121,7 +127,5 @@ Executable RakkaUnitTest ., tests Other-Modules: WikiParserTest - Extensions: - Arrows GHC-Options: -Wall -Werror diff --git a/Rakka/Attachment.hs b/Rakka/Attachment.hs index 06a9476..eb7225d 100644 --- a/Rakka/Attachment.hs +++ b/Rakka/Attachment.hs @@ -1,46 +1,47 @@ +{-# LANGUAGE + TypeOperators + , UnicodeSyntax + #-} 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 - = unsafePerformIO $ - do [xmlStr] <- runX ( setErrorMsgHandler False fail - >>> - constA attachment - >>> + = do [xmlStr] ← runLA ( constA attachment + ⋙ serializeToXmlTree - >>> - writeDocumentToString [ (a_indent, v_1) ] - ) + ⋙ + writeDocumentToString [ withIndent yes ] + ) () return xmlStr - deserializeFromString :: String -> t + deserializeFromString ∷ String → τ 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 diff --git a/Rakka/Authorization.hs b/Rakka/Authorization.hs index 97927c5..4ba4f12 100644 --- a/Rakka/Authorization.hs +++ b/Rakka/Authorization.hs @@ -1,3 +1,8 @@ +{-# LANGUAGE + OverloadedStrings + , UnicodeSyntax + #-} +-- FIXME: authentication module Rakka.Authorization ( AuthDB , mkAuthDB @@ -7,31 +12,30 @@ module Rakka.Authorization , delUser ) where - -import qualified Codec.Binary.UTF8.String as UTF8 +import Control.Applicative import Control.Concurrent.STM -import Control.Monad 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.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 Prelude.Unicode import Rakka.SystemConfig import System.Directory import System.FilePath - 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 @@ -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 - = 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 $ - 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 - -delUser :: MonadIO m => AuthDB -> String -> m () +delUser ∷ MonadIO m ⇒ AuthDB → Text → m () 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 - -loadUserMap :: FilePath -> IO UserMap +loadUserMap ∷ FilePath → IO UserMap 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 - 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" - hash = digest sha1 "" + hash = digestBS' sha1 "" 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 ea82209..c526c89 100644 --- a/Rakka/Environment.hs +++ b/Rakka/Environment.hs @@ -1,14 +1,16 @@ +{-# LANGUAGE + UnicodeSyntax + #-} 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 Network +import Network.Socket 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 Text.XML.HXT.Arrow.XmlIOStateArrow - +import Text.XML.HXT.Arrow.XmlState logger :: String logger = "Rakka.Environment" @@ -43,15 +44,13 @@ data Environment = Environment { , envAuthDB :: !AuthDB } - -setupEnv :: FilePath -> PortNumber -> IO Environment -setupEnv lsdir portNum +setupEnv ∷ FilePath → ServiceName → IO Environment +setupEnv lsdir port = do let lucuConf = LC.defaultConfig { - LC.cnfServerPort = PortNumber portNum + LC.cnfServerPort = port } reposPath = lsdir "repos" interpTable = mkInterpTable - 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 - return Environment { envLocalStateDir = lsdir , envLucuConf = lucuConf @@ -73,28 +71,27 @@ setupEnv lsdir portNum , envAuthDB = authDB } where - makeDraft' :: InterpTable -> Page -> IO Document + makeDraft' ∷ InterpTable → Page → IO Document 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 - -mkInterpTable :: InterpTable +mkInterpTable ∷ InterpTable 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 - listToTable :: [Interpreter] -> InterpTable + listToTable ∷ [Interpreter] → InterpTable 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 ab2ae88..f845f7e 100644 --- a/Rakka/Page.hs +++ b/Rakka/Page.hs @@ -1,3 +1,8 @@ +{-# LANGUAGE + Arrows + , TypeOperators + , UnicodeSyntax + #-} module Rakka.Page ( PageName , Page(..) @@ -27,30 +32,40 @@ module Rakka.Page , 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 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 Data.CaseInsensitive (CI) +import qualified Data.CaseInsensitive as CI 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 Prelude.Unicode 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 @@ -120,37 +135,37 @@ pageRevision p -- 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 - 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" } - -mkPageFragmentURI :: URI -> PageName -> String -> URI +mkPageFragmentURI ∷ URI → PageName → Text → URI 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) @@ -233,10 +248,10 @@ xmlizePage -> 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) )) -<< () @@ -246,10 +261,10 @@ xmlizePage -> 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 - Just x -> sattr "lang" x + Just x -> sattr "lang" (T.unpack $ CI.foldedCase x) Nothing -> none ) += ( case entityType page of @@ -273,9 +288,9 @@ xmlizePage 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" @@ -288,25 +303,23 @@ xmlizePage ) )) -<< () - -parseXmlizedPage :: (ArrowXml a, ArrowChoice a) => a (PageName, XmlTree) Page +parseXmlizedPage ∷ (ArrowXml (⇝), ArrowChoice (⇝)) ⇒ (PageName, XmlTree) ⇝ Page 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 @@ -343,18 +356,17 @@ parseEntity (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 - , entityLanguage = lang + , entityLanguage = CI.mk ∘ T.pack <$> lang , entityIsTheme = isTheme , entityIsFeed = isFeed , entityIsLocked = isLocked @@ -362,7 +374,7 @@ parseEntity , entityRevision = undefined , entityLastMod = undefined , entitySummary = summary - , entityOtherLang = M.fromList otherLang + , entityOtherLang = M.fromList ((CI.mk ∘ T.pack ⁂ T.pack) <$> otherLang) , entityContent = content , entityUpdateInfo = updateInfo } @@ -375,16 +387,13 @@ parseEntity | otherwise = x : dropWhitespace xs - -parseUpdateInfo :: (ArrowXml a, ArrowChoice a) => a XmlTree UpdateInfo +parseUpdateInfo ∷ (ArrowXml (⇝), ArrowChoice (⇝)) ⇒ XmlTree ⇝ UpdateInfo 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 c589cec..a6fc01f 100644 --- a/Rakka/Resource.hs +++ b/Rakka/Resource.hs @@ -1,3 +1,8 @@ +{-# LANGUAGE + Arrows + , DoAndIfThenElse + , UnicodeSyntax + #-} module Rakka.Resource ( runIdempotentA , runIdempotentA' @@ -9,26 +14,28 @@ module Rakka.Resource , getUserID ) where - 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 Data.Monoid.Unicode +import qualified Data.Text as T 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 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" @@ -80,55 +87,53 @@ runIdempotentA' a ) 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 - >>> + ⋙ a ) rsrc - -- 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 - >>> - setErrorMsgHandler False (abort UnprocessableEntitiy [] . Just) - >>> + ⋙ + setErrorMsgHandler False (abort UnprocessableEntitiy [] ∘ Just) + ⋙ validator ) - -getInputReader :: Resource (IOSArrow b XmlTree) +getInputReader ∷ Resource (IOSArrow b XmlTree) getInputReader - = do mimeType <- getContentType + = do mimeType ← getContentType case mimeType of Nothing - -> getFailingReader BadRequest [] (Just "Missing Content-Type") + → getFailingReader BadRequest [] (Just "Missing Content-Type") Just (MIMEType "text" "xml" _) - -> getXmlReader + → getXmlReader Just (MIMEType "application" "xml" _) - -> getXmlReader + → getXmlReader Just t - -> getFailingReader UnsupportedMediaType [] (Just $ "Unsupported media type: " ++ show t) + → getFailingReader UnsupportedMediaType [] + (Just $ "Unsupported media type: " ⊕ show t) where getXmlReader - = do req <- input defaultLimit + = do req ← input defaultLimit 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)) @@ -149,53 +154,51 @@ getEntityType ] -outputXmlPage :: XmlTree -> [(MIMEType, IOSArrow XmlTree XmlTree)] -> Resource () +outputXmlPage ∷ XmlTree → [(MIMEType, IOSArrow XmlTree XmlTree)] → Resource () outputXmlPage tree formatters - = do mType <- getEntityType + = do mType ← getEntityType 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)] - -outputXml :: XmlTree -> Resource () +outputXml ∷ XmlTree → Resource () 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 - = do auth <- getAuthorization + = do auth ← getAuthorization 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 db8552d..31893e0 100644 --- a/Rakka/Resource/Index.hs +++ b/Rakka/Resource/Index.hs @@ -1,22 +1,23 @@ +{-# LANGUAGE + UnicodeSyntax + #-} 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 - = 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 diff --git a/Rakka/Resource/Object.hs b/Rakka/Resource/Object.hs index d4db7db..3a98b1e 100644 --- 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 - import qualified Codec.Binary.UTF8.String as UTF8 +import Control.Monad.Unicode +import qualified Data.Text as T import Network.HTTP.Lucu +import Prelude.Unicode 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 - , resGet = Just $ getPathInfo >>= handleGet env . toPageName + , resGet = Just $ getPathInfo ≫= handleGet env ∘ toPageName , 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 diff --git a/Rakka/Resource/PageEntity.hs b/Rakka/Resource/PageEntity.hs index a1d4b02..1388f71 100644 --- 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 - +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 Data.CaseInsensitive as CI 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 Prelude.Unicode 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 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 - | null name = return Nothing - | isLower $ head name = return Nothing -- 先頭の文字が小文字であってはならない + | T.null name = return Nothing + | isLower $ T.head name = return Nothing -- 先頭の文字が小文字であってはならない | otherwise - = return $ Just $ ResourceDef { + = pure $ Just ResourceDef { resUsesNativeThread = False , resIsGreedy = True , resGet = Just $ handleGet env name @@ -41,9 +59,8 @@ fallbackPageEntity env path , 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 @@ -62,37 +79,36 @@ handleGet env name else handleRedirect env -< page - {- 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 - -> 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 @@ -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 - -> 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 - -> 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 - mkPageURIStr :: URI -> PageName -> String + mkPageURIStr :: URI → PageName → String 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) "" - -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 - = proc (mainPageName, mainPage, subPageName) -> - do langM <- case mainPage of + = proc (mainPageName, mainPage, subPageName) → + do langM ← case mainPage of Nothing - -> returnA -< Nothing + → returnA ⤙ Nothing 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 - -> returnA -< subPage + → returnA ⤙ subPage 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 - localize :: (ArrowChoice a, ArrowIO a) => Storage -> a (LanguageTag, Page) Page + localize ∷ (ArrowChoice (⇝), ArrowIO (⇝)) ⇒ Storage → (LanguageTag, Page) ⇝ Page 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 -} -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) - -> 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 - -> 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 {- -} -handlePageNotFound :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a PageName (Resource ()) +handlePageNotFound ∷ (ArrowXml (⇝), ArrowChoice (⇝), ArrowIO (⇝)) + ⇒ Environment + → PageName ⇝ Resource () 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 - -> 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 - = 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 - = do userID <- getUserID env - status <- deletePage (envStorage env) userID name + = do userID ← getUserID env + status ← deletePage (envStorage env) userID name setStatus status - -mkFeedList :: (ArrowIO a, ArrowXml a) => Environment -> a b XmlTree +mkFeedList ∷ (ArrowIO (⇝), ArrowXml (⇝)) ⇒ Environment → β ⇝ XmlTree 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 @@ -606,23 +616,18 @@ mkGlobalJSList env | otherwise -> none -< () - -findJavaScripts :: Storage -> IO [PageName] +findJavaScripts ∷ Storage → IO [PageName] 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" - result <- searchPages sto cond + result ← searchPages sto cond 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 64c159e..302360e 100644 --- a/Rakka/Resource/Render.hs +++ b/Rakka/Resource/Render.hs @@ -1,16 +1,24 @@ +{-# LANGUAGE + Arrows + , TypeOperators + , UnicodeSyntax + #-} 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 Control.Arrow.Unicode import Control.Monad.Trans +import Control.Monad.Unicode import qualified Data.ByteString.Lazy as Lazy +import Data.Text as T import Network.HTTP.Lucu import OpenSSL.EVP.Base64 +import Prelude.Unicode 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.XmlIOStateArrow +import Text.XML.HXT.Arrow.XmlState 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 - , resPost = Just $ getPathInfo >>= handleRender env . toPageName + , resPost = Just $ getPathInfo ≫= handleRender env ∘ toPageName , resPut = Nothing , resDelete = Nothing } where - toPageName :: [String] -> PageName - toPageName = UTF8.decodeString . joinPath - + toPageName ∷ [String] → PageName + toPageName = T.pack ∘ UTF8.decodeString ∘ joinPath {- --- Request --- @@ -76,32 +81,30 @@ handleRender env name -> (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) - -> 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 423bfdc..56f99c0 100644 --- 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 - +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 Data.List import Data.Maybe +import Data.Monoid.Unicode +import Data.Text (Text) +import qualified Data.Text as T import Data.Time +import qualified Data.Time.RFC1123 as RFC1123 import Network.HTTP.Lucu -import Network.HTTP.Lucu.RFC1123DateTime import Network.URI hiding (query, fragment) +import Prelude.Unicode 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 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 @@ -45,11 +61,9 @@ resultsPerSection = 10 maxSectionWindowSize :: Int maxSectionWindowSize = 10 - -findQueryParam :: String -> [FormData] -> Maybe String +findQueryParam ∷ String → [(String, FormData)] → Maybe String findQueryParam name qps - = do fd <- find (\ qp -> fdName qp == name) qps - return $ UTF8.toString $ fdContent fd + = UTF8.toString ∘ fdContent <$> lookup name qps {- -} -handleSearch :: Environment -> Resource () +handleSearch ∷ Environment → Resource () handleSearch env - = do params <- getQueryForm + = do params ← getQueryForm 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 - 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 - BaseURI baseURI <- getSysConf (envSysConf env) + BaseURI baseURI ← getSysConf (envSysConf env) 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 - mkCond :: String -> Maybe String -> Int -> Int -> IO Condition + mkCond ∷ Text → Maybe Text → Int → Int → IO Condition mkCond query order from to - = do cond <- newCondition + = do cond ← newCondition 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" - += attr "name" (arr hpPageName >>> mkText) - += attr "lastModified" ( arrIO (utcToLocalZonedTime . hpLastMod) - >>> + += attr "name" (arr (T.unpack ∘ hpPageName) ⋙ mkText) + += attr "lastModified" ( arrIO (utcToLocalZonedTime ∘ hpLastMod) + ⋙ arr formatW3CDateTime - >>> + ⋙ mkText ) += ( arrL hpSnippet - >>> + ⋙ mkSnippetTree ) ) - mkSnippetTree :: (ArrowChoice a, ArrowXml a) => a SnippetFragment XmlTree + mkSnippetTree ∷ (ArrowChoice (⇝), ArrowXml (⇝)) ⇒ SnippetFragment ⇝ XmlTree 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 - -> 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 - 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" - >>> - arr (\ x -> uriToString id (mkPageURI baseURI x) "") - >>> + ⋙ + arr (\x → uriToString id (mkPageURI baseURI (T.pack x)) "") + ⋙ mkText ) - += (getAttrValue "name" >>> mkText) + += (getAttrValue "name" ⋙ mkText) ) += ( eelem "div" += sattr "class" "date" += ( getAttrValue "lastModified" - >>> + ⋙ arr (zonedTimeToUTC . fromJust . parseW3CDateTime) - >>> + ⋙ arrIO utcToLocalZonedTime - >>> - arr formatRFC1123DateTime - >>> + ⋙ + arr RFC1123.format + ⋙ mkText ) ) += ( eelem "p" += ( getChildren - >>> + ⋙ choiceA [ isText :-> this , hasName "boundary" :-> txt " ... " , hasName "hit" :-> ( eelem "span" @@ -316,29 +325,29 @@ searchResultToXHTML env arr (fst . snd . snd) &&& ( arr (snd . snd) - >>> + ⋙ mkSectionWindow ) ) - >>> + ⋙ 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 - >>> + ⋙ 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 - arrL id -< [begin .. end] + arrL id ⤙ [begin .. end] mkSectionURI :: Arrow a => URI -> a (String, (Maybe String, Int)) URI @@ -378,7 +387,7 @@ searchResultToXHTML env } uriToText :: ArrowXml a => a URI XmlTree - uriToText = arr (\ uri -> uriToString id uri "") >>> mkText + uriToText = arr (\ uri -> uriToString id uri "") ⋙ mkText -- FIXME: localize @@ -386,6 +395,6 @@ readSubPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) => 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 cb19011..3ae3f42 100644 --- 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 - +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.Text (Text) +import qualified Data.Text as T import Network.HTTP.Lucu +import Prelude.Unicode 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 ==> 全設定値を返す @@ -28,7 +43,6 @@ resSystemConfig env , resDelete = Nothing } - {- Rakka @@ -41,77 +55,72 @@ handleGet env -> 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 1bcdbf9..df1f5c3 100644 --- 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 ) ] ) - output xmlStr + output $ UTF8.encodeString xmlStr where mkResponseTree :: ArrowXml a => a b XmlTree mkResponseTree diff --git a/Rakka/Resource/Users.hs b/Rakka/Resource/Users.hs index fa61ad8..a892c9f 100644 --- 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 - -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 @@ -40,41 +51,37 @@ resUsers env [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 - 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 - 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 @@ -84,35 +91,34 @@ handleGet env < HTTP/1.1 201 Created -} -handlePut :: Environment -> Resource () +handlePut ∷ Environment → Resource () 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 - = do userID <- getUserID env + = do userID ← getUserID env when (isNothing userID) - $ abort Forbidden [] Nothing + $ abort Forbidden [] Nothing - path <- getPathInfo + path ← getPathInfo 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 diff --git a/Rakka/Storage/DefaultPage.hs b/Rakka/Storage/DefaultPage.hs index e6f51a5..f9b73f0 100644 --- 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 - -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" - -findAllDefaultPages :: IO (Set PageName) +findAllDefaultPages ∷ IO (Set PageName) 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" - else - -- FIXME: この getDataFileName の使ひ方は undocumented - findAllIn =<< getDataFileName "defaultPages" + else + -- FIXME: This usage of getDataFileName is undocumented. + findAllIn =≪ getDataFileName "defaultPages" where - findAllIn :: FilePath -> IO (Set PageName) + findAllIn ∷ FilePath → IO (Set PageName) 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 @@ -66,8 +70,8 @@ getDefaultDirContents dir 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 @@ -106,27 +110,25 @@ loadPageFile name path ) return page - -loadPageFileA :: IOStateArrow s (PageName, FilePath) Page +loadPageFileA ∷ IOStateArrow s (PageName, FilePath) Page 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 - returnA -< page { - entityRevision = 0 - , entityLastMod = lastMod - } + returnA ⤙ page { + entityRevision = 0 + , entityLastMod = lastMod + } 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 bedc9ea..8b3cbeb 100644 --- a/Rakka/Storage/Impl.hs +++ b/Rakka/Storage/Impl.hs @@ -1,3 +1,7 @@ +{-# LANGUAGE + OverloadedStrings + , UnicodeSyntax + #-} module Rakka.Storage.Impl ( getPage' , putPage' @@ -9,19 +13,23 @@ module Rakka.Storage.Impl , putAttachment' ) where - +import Control.Applicative 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.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 Prelude.Unicode 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) -searchIndex :: Database -> Condition -> IO SearchResult +searchIndex ∷ Database → Condition → IO SearchResult searchIndex index cond - = do (ids, hint) <- searchDatabase' index cond + = do (ids, hint) ← searchDatabase' index cond let (total, words) = parseHint hint - pages <- mapM (fromId words) ids + pages ← mapM (fromId words) ids return SearchResult { srTotal = total , srPages = pages } where - parseHint :: [(String, Int)] -> (Int, [String]) + parseHint ∷ [(Text, Int)] → (Int, [Text]) parseHint xs = let total = fromJust $ lookup "" xs - words = filter (/= "") $ map fst xs + words = filter ((¬) ∘ T.null) $ map fst xs in (total, words) - fromId :: [String] -> DocumentID -> IO HitPage + fromId ∷ [Text] → DocumentID → IO HitPage 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 - 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] - 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] - 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 () diff --git a/Rakka/Storage/Repos.hs b/Rakka/Storage/Repos.hs index a6977e6..6a90ed6 100644 --- a/Rakka/Storage/Repos.hs +++ b/Rakka/Storage/Repos.hs @@ -1,4 +1,10 @@ -- -*- coding: utf-8 -*- +{-# LANGUAGE + DoAndIfThenElse + , RecordWildCards + , ScopedTypeVariables + , UnicodeSyntax + #-} module Rakka.Storage.Repos ( findAllPagesInRevision , getDirContentsInRevision @@ -10,16 +16,21 @@ module Rakka.Storage.Repos , putAttachmentIntoRepository ) where - +import Control.Applicative 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.Monoid.Unicode 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 Prelude.Unicode import Rakka.Attachment import Rakka.Page import Rakka.SystemConfig @@ -85,7 +96,6 @@ findAllPagesInRevision repos rev decodePath :: FilePath -> PageName decodePath = decodePageName . makeRelative root . dropExtension - 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) - 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 @@ -169,7 +178,7 @@ loadPageInRepository repos name rev 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 @@ -181,11 +190,10 @@ loadPageInRepository repos name rev , 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 } @@ -195,7 +203,7 @@ loadPageInRepository repos name rev 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) @@ -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 - = 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 - 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 - $ do exists <- isFile (mkPagePath name) + $ do exists ← isFile (mkPagePath name') 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 @@ -295,20 +304,20 @@ putPageIntoRepository repos userID page deleteEmptyParentDirectories oldPath createPage :: PageName -> Txn () - createPage name - = do let path = mkPagePath name + createPage name' + = do let path = mkPagePath name' 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 () - 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 @@ -317,24 +326,24 @@ putPageIntoRepository repos userID page 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 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: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 @@ -399,12 +408,12 @@ deleteEmptyParentDirectories path 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 @@ -417,12 +426,12 @@ loadAttachmentInRepository repos pName aName rev else return Nothing where - path :: FilePath + path ∷ FilePath 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 diff --git a/Rakka/Storage/Types.hs b/Rakka/Storage/Types.hs index e9b848b..75d8ef1 100644 --- a/Rakka/Storage/Types.hs +++ b/Rakka/Storage/Types.hs @@ -1,3 +1,6 @@ +{-# LANGUAGE + UnicodeSyntax + #-} module Rakka.Storage.Types ( Storage(..) , IndexReq(..) @@ -6,14 +9,13 @@ module Rakka.Storage.Types , 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 { @@ -21,13 +23,11 @@ data Storage , stoIndexChan :: !(TChan IndexReq) } - data IndexReq = RebuildIndex | SyncIndex | SearchIndex !Condition !(TMVar SearchResult) - data SearchResult = SearchResult { srTotal :: !Int @@ -35,20 +35,18 @@ data SearchResult } deriving (Show, Eq) - data HitPage = HitPage { hpPageName :: !PageName , hpPageRev :: RevNum , hpLastMod :: UTCTime - , hpSummary :: Maybe String + , hpSummary :: Maybe Text , hpSnippet :: [SnippetFragment] } deriving (Show, Eq) - 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 aa1e579..029d307 100644 --- a/Rakka/SystemConfig.hs +++ b/Rakka/SystemConfig.hs @@ -1,3 +1,9 @@ +{-# LANGUAGE + DeriveDataTypeable + , OverloadedStrings + , ScopedTypeVariables + , UnicodeSyntax + #-} module Rakka.SystemConfig ( SystemConfig , SysConfValue(..) @@ -17,28 +23,37 @@ module Rakka.SystemConfig , Languages(..) , GlobalLock(..) - , serializeStringPairs - , deserializeStringPairs + , serializeTextPairs + , deserializeTextPairs + , serializeMap + , deserializeMap ) where - +import Control.Applicative 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.Monad.Unicode 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.Monoid.Unicode +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T import GHC.Conc (unsafeIOToSTM) -import Network +import Network.BSD 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 Prelude.Unicode 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 System.IO.Unsafe import System.Log.Logger - logger :: String logger = "Rakka.SystemConfig" @@ -61,13 +76,11 @@ data SystemConfig = SystemConfig { , 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 @@ -78,49 +91,42 @@ mkSystemConfig lc repos , 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 - = 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 - 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 - = 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 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 - -> 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 @@ -135,42 +141,41 @@ 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 - = 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 - 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 - 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 - createValueEntry :: FilePath -> Txn () + createValueEntry ∷ FilePath → Txn () createValueEntry path - = do createParentDirectories path - makeFile path + = do createParentDirectories path + makeFile path - createParentDirectories :: FilePath -> Txn () + createParentDirectories ∷ FilePath → Txn () 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 @@ -183,51 +188,49 @@ setSysConfA = (arrIO .) . setSysConf fromConfPath :: FilePath -> FilePath fromConfPath = ("/config" ) - -serializeStringPairs :: [(String, String)] -> String -serializeStringPairs = joinWith "\n" . map serializePair' +serializeTextPairs ∷ [(Text, Text)] → Text +serializeTextPairs = T.intercalate "\n" ∘ (serializePair' <$>) 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 - 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" - 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 - $ 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 - 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 @@ -236,28 +239,25 @@ instance SysConfValue BaseURI where 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" - -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" - 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" ) diff --git a/Rakka/Utils.hs b/Rakka/Utils.hs index 15bc6f4..3148c6b 100644 --- a/Rakka/Utils.hs +++ b/Rakka/Utils.hs @@ -1,3 +1,9 @@ +{-# LANGUAGE + Arrows + , OverloadedStrings + , TypeOperators + , UnicodeSyntax + #-} module Rakka.Utils ( yesOrNo , trueOrFalse @@ -10,35 +16,34 @@ module Rakka.Utils , 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 Data.Monoid.Unicode +import Data.String import Magic import Network.HTTP.Lucu import Network.URI +import Prelude.Unicode import System.IO.Unsafe - -yesOrNo :: Bool -> String +yesOrNo ∷ Bool → String yesOrNo True = "yes" yesOrNo False = "no" - -trueOrFalse :: Bool -> String +trueOrFalse ∷ Bool → String trueOrFalse True = "true" trueOrFalse False = "false" - -parseYesOrNo :: ArrowChoice a => a String Bool -parseYesOrNo - = proc str -> do case str of - "yes" -> returnA -< True - "no" -> returnA -< False - _ -> returnA -< error ("Expected yes or no: " ++ str) - +parseYesOrNo ∷ (Eq s, Show s, IsString s, ArrowChoice (⇝)) ⇒ s ⇝ Bool +parseYesOrNo + = 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 diff --git a/Rakka/Validation.hs b/Rakka/Validation.hs index 73a83e7..417e4f2 100644 --- a/Rakka/Validation.hs +++ b/Rakka/Validation.hs @@ -1,58 +1,39 @@ +{-# LANGUAGE + DoAndIfThenElse + , UnicodeSyntax + #-} 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 - = 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" - -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 - - localDirExists <- doesLocalDirExist + localDirExists ← doesLocalDirExist 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 488cd2e..4ec4738 100644 --- a/Rakka/W3CDateTime.hs +++ b/Rakka/W3CDateTime.hs @@ -1,9 +1,9 @@ +-- FIXME: use time-w3c module Rakka.W3CDateTime ( formatW3CDateTime , parseW3CDateTime ) where - import Control.Monad import Data.Time import Prelude hiding (min) diff --git a/Rakka/Wiki.hs b/Rakka/Wiki.hs index a519d34..bdecec7 100644 --- a/Rakka/Wiki.hs +++ b/Rakka/Wiki.hs @@ -1,3 +1,6 @@ +{-# LANGUAGE + UnicodeSyntax + #-} module Rakka.Wiki ( WikiPage @@ -17,107 +20,97 @@ module Rakka.Wiki , 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] - data Element = Block !BlockElement | Inline !InlineElement deriving (Eq, Show) - -type Attribute = (String, String) - +type Attribute = (CI Text, Text) data BlockElement = Heading { - headingLevel :: !Int - , headingText :: !String + headingLevel ∷ !Int + , headingText ∷ !Text } | HorizontalLine | List { - listType :: !ListType - , listItems :: ![ListItem] + listType ∷ !ListType + , listItems ∷ ![ListItem] } | DefinitionList ![Definition] - | Preformatted ![InlineElement] - | Paragraph ![InlineElement] - | Div ![Attribute] ![Element] + | Preformatted ![InlineElement] + | Paragraph ![InlineElement] + | Div ![Attribute] ![Element] | EmptyBlock - | BlockCmd !BlockCommand + | BlockCmd !BlockCommand deriving (Eq, Show) - data InlineElement - = Text !String + = Text !Text | Italic ![InlineElement] - | Bold ![InlineElement] + | Bold ![InlineElement] | ObjectLink { - objLinkPage :: !PageName - , objLinkText :: !(Maybe String) + objLinkPage ∷ !PageName + , objLinkText ∷ !(Maybe Text) } | PageLink { - linkPage :: !(Maybe PageName) - , linkFragment :: !(Maybe String) - , linkText :: !(Maybe String) + linkPage ∷ !(Maybe PageName) + , linkFragment ∷ !(Maybe Text) + , linkText ∷ !(Maybe Text) } | ExternalLink { - extLinkURI :: !URI - , extLinkText :: !(Maybe String) + extLinkURI ∷ !URI + , extLinkText ∷ !(Maybe Text) } | LineBreak ![Attribute] - | Span ![Attribute] ![InlineElement] + | Span ![Attribute] ![InlineElement] | 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) - data ListType = Bullet | Numbered deriving (Eq, Show) - type ListItem = [Element] - data Definition = Definition { - defTerm :: ![InlineElement] - , defDesc :: ![InlineElement] + defTerm ∷ ![InlineElement] + , defDesc ∷ ![InlineElement] } deriving (Eq, Show) - data CommandType = InlineCommandType | BlockCommandType deriving (Eq, Show) - data BlockCommand = BlockCommand { - bCmdName :: !String - , bCmdAttributes :: ![Attribute] - , bCmdContents :: ![BlockElement] + bCmdName ∷ !Text + , bCmdAttributes ∷ ![Attribute] + , bCmdContents ∷ ![BlockElement] } deriving (Eq, Show) - data InlineCommand = InlineCommand { - iCmdName :: !String + iCmdName :: !Text , iCmdAttributes :: ![Attribute] , iCmdContents :: ![InlineElement] } diff --git a/Rakka/Wiki/Engine.hs b/Rakka/Wiki/Engine.hs index 17c2933..02e987c 100644 --- 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 @@ -7,16 +14,25 @@ module Rakka.Wiki.Engine , 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 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 Prelude.Unicode 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 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 - -> 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" _ _ - -- - -> returnA -< [ Paragraph [Image (Left $ fromJust dataURI) Nothing] ] - - _ -> if isJust dataURI then - -- - -- application/zip - -- - 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" _ _ + -- + → returnA ⤙ [ Paragraph [Image (Left $ fromJust dataURI) Nothing] ] + + _ → if isJust dataURI then + -- + -- application/zip + -- + 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 @@ -80,35 +95,34 @@ wikifyPage interpTable | 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) - -> 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" _ _ - -- - -> returnA -< [ Paragraph [Image (Left dataURI) Nothing] ] - - - _ - -- - -- application/zip (19372 bytes) - -- - -> 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" _ _ + -- + -> returnA -< [ Paragraph [Image (Left dataURI) Nothing] ] + + _ -- + -- application/zip (19372 bytes) + -- + -> 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 @@ -117,25 +131,25 @@ wikifyBin interpTable , uriPath = show m ++ ";base64," ++ (L8.unpack $ encodeBase64LBS b) } - -cmdTypeOf :: InterpTable -> String -> Maybe CommandType +cmdTypeOf ∷ Alternative f ⇒ InterpTable → Text → f CommandType 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 - -> 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) => @@ -220,115 +234,112 @@ interpretCommands sto sysConf interpTable 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 - -> fail ("no such interpreter: " ++ bCmdName cmd) + → fail ("no such interpreter: " ⊕ T.unpack (bCmdName cmd)) 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 - -> fail ("no such interpreter: " ++ iCmdName cmd) + → fail ("no such interpreter: " ⊕ T.unpack (iCmdName cmd)) 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 - = proc tree -> - do redir <- maybeA (getXPathTreesInDoc "/page/@redirect") -< tree + = proc tree → + do redir ← maybeA (getXPathTreesInDoc "/page/@redirect") ⤙ tree case redir of - Nothing -> makeEntityDraft -< tree - Just _ -> makeRedirectDraft -< tree + Nothing → makeEntityDraft ⤙ tree + Just _ → makeRedirectDraft ⤙ tree where - makeEntityDraft :: (ArrowXml a, ArrowChoice a, ArrowIO a) => a XmlTree Document + makeEntityDraft ∷ XmlTree ⇝ Document 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 - Just s -> arrIO2 addHiddenText -< (doc, s) - Nothing -> returnA -< () + Just s → arrIO2 addHiddenText ⤙ (doc, T.pack s) + Nothing → returnA ⤙ () -- 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) - >>> + ⋙ arrIO2 addHiddenText - >>> + ⋙ none - ) -< (doc, otherLangs) + ) ⤙ (doc, T.pack <$> otherLangs) 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" _ - -- 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 _ _ _ - -> returnA -< () + → returnA ⤙ () - returnA -< doc + returnA ⤙ doc - makeRedirectDraft :: (ArrowXml a, ArrowChoice a, ArrowIO a) => a XmlTree Document + makeRedirectDraft ∷ XmlTree ⇝ Document 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 "@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 @@ -345,23 +356,23 @@ makeDraft interpTable 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 - >> 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 - 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 @@ -386,18 +397,18 @@ makeDraft interpTable 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 - -> 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 @@ -427,8 +438,7 @@ makePageLinkList sto sysConf interpTable ++ concatMap extractFromInline desc - -wikifyParseError :: Arrow a => a ParseError WikiPage +wikifyParseError ∷ Arrow (⇝) ⇒ ParseError ⇝ WikiPage 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 5f7c7d8..c1e63f5 100644 --- 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 - -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 @@ -30,13 +41,12 @@ formatElement 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) - -> case block of + → case block of Heading level text - -> formatHeading -< (level, text) + → formatHeading ⤙ (level, text) HorizontalLine -> eelem "hr" -< () @@ -78,12 +88,12 @@ formatBlock ) -< (baseURI, (attrs, contents)) -formatHeading :: ArrowXml a => a (Int, String) XmlTree +formatHeading ∷ ArrowXml (⇝) ⇒ (Int, Text) ⇝ XmlTree formatHeading - = proc (level, text) - -> mkelem ("h" ++ show level) + = proc (level, T.unpack → text) + -> mkelem ("h" ⊕ show level) [ sattr "id" text ] - [ txt text ] -<< () + [ txt text ] ⤛ () formatListElement :: (ArrowXml a, ArrowChoice a) => a (URI, BlockElement) XmlTree @@ -154,13 +164,12 @@ formatParagraph formatInline ) - -formatInline :: (ArrowXml a, ArrowChoice a) => a (URI, InlineElement) XmlTree +formatInline ∷ (ArrowXml (⇝), ArrowChoice (⇝)) ⇒ (URI, InlineElement) ⇝ XmlTree formatInline = proc (baseURI, i) - -> case i of + → case i of Text text - -> mkText -< text + → mkText ⤙ T.unpack text Italic contents -> formatElem "i" -< (baseURI, [], contents) @@ -197,87 +206,78 @@ formatInline _ -> arr (error . ("formatInline: unsupported InlineElement: " ++) . show) -< i where - formatElem :: (ArrowXml a, ArrowChoice a) => + formatElem ∷ (ArrowXml (⇝), ArrowChoice (⇝)) ⇒ String - -> a (URI, [Attribute], [InlineElement]) XmlTree + → (URI, [Attribute], [InlineElement]) ⇝ XmlTree formatElem name = proc (baseURI, attrs, contents) - -> ( eelem name - += ( arrL (fst . snd) - >>> - attrFromPair + → ( eelem name + += ( arrL (fst ∘ snd) + ⋙ + attrFromPair ) += ( (arr fst &&& arrL (snd . snd)) - >>> + ⋙ 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) - -> 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) - -> 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) - -> 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) - -> 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" - += 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 - 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 32e1a3a..6bce1d0 100644 --- a/Rakka/Wiki/Interpreter.hs +++ b/Rakka/Wiki/Interpreter.hs @@ -1,3 +1,6 @@ +{-# LANGUAGE + UnicodeSyntax + #-} module Rakka.Wiki.Interpreter ( Interpreter(..) , InterpreterContext(..) @@ -6,22 +9,21 @@ module Rakka.Wiki.Interpreter , 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 { - iciName :: !String - , iciInterpret :: !(InterpreterContext -> InlineCommand -> IO InlineElement) + iciName ∷ !Text + , iciInterpret ∷ !(InterpreterContext → InlineCommand → IO InlineElement) } | BlockCommandInterpreter { - bciName :: !String - , bciInterpret :: !(InterpreterContext -> BlockCommand -> IO BlockElement) + bciName ∷ !Text + , bciInterpret ∷ !(InterpreterContext → BlockCommand → IO BlockElement) } @@ -35,12 +37,10 @@ data InterpreterContext , ctxSysConf :: !SystemConfig } - -commandName :: Interpreter -> String +commandName ∷ Interpreter → Text commandName (InlineCommandInterpreter name _) = name commandName (BlockCommandInterpreter name _) = name - -commandType :: Interpreter -> CommandType +commandType ∷ Interpreter → CommandType commandType (InlineCommandInterpreter _ _) = InlineCommandType commandType (BlockCommandInterpreter _ _) = BlockCommandType diff --git a/Rakka/Wiki/Interpreter/Base.hs b/Rakka/Wiki/Interpreter/Base.hs index ed81494..7395053 100644 --- 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 - -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 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 @@ -27,7 +38,6 @@ interpreters = [ lineBreakInterp , configurationInterp ] - lineBreakInterp :: Interpreter lineBreakInterp = InlineCommandInterpreter { iciName = "br" @@ -60,43 +70,44 @@ pageNameInterp = InlineCommandInterpreter { = \ ctx _ -> return $ Text (fromMaybe "" $ ctxPageName ctx) } - -otherLangsInterp :: Interpreter +otherLangsInterp ∷ Interpreter 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 - _ -> 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 - 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 - langName = fromMaybe langTag (M.lookup langTag m) + langName = fromMaybe (CI.foldedCase langTag) + (M.lookup langTag m) 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))] @@ -126,17 +137,17 @@ newPageInterp -- value="Edit" -- onclick="Rakka.editPage(\"Foo\")" -- class="editButton controls" /> -editPageInterp :: Interpreter +editPageInterp ∷ Interpreter 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) - , ("onclick", "Rakka.editPage(\"" ++ name ++ "\")") + , ("onclick", "Rakka.editPage(\"" ⊕ name ⊕ "\")") , ("class" , "editButton controls") ] in @@ -180,12 +191,12 @@ searchFieldInterp -- -configurationInterp :: Interpreter +configurationInterp ∷ Interpreter configurationInterp = InlineCommandInterpreter { iciName = "configuration" , iciInterpret - = \ _ _ -> + = \_ _ → let attrs = [ ("type" , "button") , ("value", "Configuration") , ("class", "configButton controls") diff --git a/Rakka/Wiki/Interpreter/Image.hs b/Rakka/Wiki/Interpreter/Image.hs index 00a55de..886fdf5 100644 --- 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 +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 ] - -- [Alternative] -- ... -- -imageInterp :: Interpreter +imageInterp ∷ Interpreter imageInterp = InlineCommandInterpreter { - iciName = "img" + iciName = "img" , 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 - Just x -> x - Nothing -> error "\"src\" attribute is missing" + Just x → x + Nothing → error "\"src\" attribute is missing" 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 - 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 - 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 } @@ -67,38 +72,39 @@ imageInterp -- ... -- -- -imgFrameInterp :: Interpreter +imgFrameInterp ∷ Interpreter imgFrameInterp = BlockCommandInterpreter { - bciName = "imgframe" + bciName = "imgframe" , 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 - Just x -> x - Nothing -> error "\"src\" attribute is missing" + Just x → x + Nothing → error "\"src\" attribute is missing" 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 - 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 - 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")] - [ 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 983b459..3c66db1 100644 --- 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 - -import Data.Maybe -import Rakka.Wiki -import Rakka.Wiki.Interpreter - +import Data.Maybe +import Rakka.Wiki +import Rakka.Wiki.Interpreter interpreters :: [Interpreter] interpreters = [ outlineInterp ] diff --git a/Rakka/Wiki/Interpreter/PageList.hs b/Rakka/Wiki/Interpreter/PageList.hs index 3d5ce24..d94f67e 100644 --- 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 - -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 Network.HTTP.Lucu.RFC1123DateTime +import qualified Data.Time.RFC1123 as RFC1123 import Network.URI +import Prelude.Unicode import Rakka.Storage import Rakka.SystemConfig import Rakka.Utils @@ -51,29 +59,26 @@ recentUpdatesURLInterp -- ... -- -- -recentUpdatesInterp :: Interpreter +recentUpdatesInterp ∷ Interpreter 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 @@ -82,21 +87,21 @@ recentUpdatesInterp return (Div [("class", "recentUpdates")] [ Block (List Bullet items) ]) - mkListItem :: Bool -> HitPage -> IO ListItem + mkListItem ∷ Bool → HitPage → IO ListItem 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")] - [Inline (Text (formatRFC1123DateTime lastMod))] + [Inline (Text (T.pack $ RFC1123.format lastMod))] ) ] - ++ + ⊕ 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 1744570..3b3d7c4 100644 --- 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 - -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 @@ -41,26 +53,25 @@ blockElement cmdTypeOf , blockCmd cmdTypeOf ] - -heading :: Parser BlockElement +heading ∷ Parser BlockElement 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 - 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 - return (Heading n (x:xs)) - + pure ∘ Heading n $ T.pack (x:xs) horizontalLine :: Parser BlockElement horizontalLine = try ( do _ <- count 4 (char '-') @@ -151,19 +162,15 @@ definitionList cmdTypeOf = liftM DefinitionList (many1 definition) "description of term" -verbatim :: Parser BlockElement -verbatim = do _ <- try (string " + many (oneOf " \t\n") *> + (Preformatted ∘ (:[]) ∘ Text ∘ T.pack <$> verbatim') 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 @@ -235,10 +242,8 @@ blockCmd cmdTypeOf , bCmdAttributes = tagAttrs , bCmdContents = xs } - Just InlineCommandType -> pzero - _ -> return $ undefinedCmdErr tagName ) <|> @@ -250,35 +255,30 @@ blockCmd cmdTypeOf , bCmdAttributes = tagAttrs , bCmdContents = [] } - Just InlineCommandType -> pzero - _ -> 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")] - [ Block (Paragraph [Text ("The command `" ++ name ++ "' is not defined. " ++ + [ Block (Paragraph [Text ("The command `" ⊕ name ⊕ "' is not defined. " ⊕ "Make sure you haven't mistyped.") ]) ] - inlineElement :: CommandTypeOf -> Parser InlineElement inlineElement cmdTypeOf = try $ do skipMany comment @@ -291,31 +291,24 @@ inlineElement cmdTypeOf , inlineCmd cmdTypeOf ] - -nowiki :: Parser InlineElement -nowiki = liftM Text (try (string "> nowiki') +nowiki ∷ Parser InlineElement +nowiki = Text ∘ T.pack <$> (try (string " nowiki') 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" - 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 '\'') -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" - -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" - -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 - 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" - -inlineCmd :: CommandTypeOf -> Parser InlineElement +inlineCmd ∷ CommandTypeOf → Parser InlineElement inlineCmd cmdTypeOf - = (try $ do (tagName, tagAttrs) <- openTag + = (try $ do (tagName, tagAttrs) ← openTag 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 } - _ -> pzero + _ → pzero ) <|> (try $ do (tagName, tagAttrs) <- emptyTag @@ -414,62 +401,58 @@ inlineCmd cmdTypeOf "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 () diff --git a/tests/WikiParserTest.hs b/tests/WikiParserTest.hs index 8567072..d3ee816 100644 --- a/tests/WikiParserTest.hs +++ b/tests/WikiParserTest.hs @@ -1,30 +1,32 @@ +{-# LANGUAGE + OverloadedStrings + , UnicodeSyntax + #-} module WikiParserTest ( testData ) where - +import Control.Applicative import Data.Maybe +import Data.Text (Text) 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 - Left err -> Left (show err) - Right page -> Right page - + Left err → Left (show err) + Right page → Right page testData :: [Test] testData = [ (parseWiki "" -- 2.40.0