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
-{-# 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
data CmdOpt
- = OptPortNum PortNumber
+ = OptPortNum ServiceName
| OptLSDir FilePath
| OptUserName String
| OptGroupName String
deriving (Eq, Show)
-defaultPort :: PortNumber
-defaultPort = toEnum 8080
+defaultPort ∷ ServiceName
+defaultPort = "8080"
defaultLocalStateDir :: FilePath
defaultLocalStateDir = LOCALSTATEDIR -- replaced by CPP
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")
withSystemLock (lsdir </> "lock") $
withPidFile (lsdir </> "pid") $
do setupLogger opts
- env <- setupEnv lsdir portNum
+ env ← setupEnv lsdir portNum
rebuildIndexIfRequested env opts
, (["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
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
Rakka.Wiki.Engine
Rakka.Wiki.Formatter
Rakka.Wiki.Parser
- Extensions:
- Arrows, ExistentialQuantification, ScopedTypeVariables,
- DeriveDataTypeable, FlexibleInstances
+
GHC-Options:
-Wall -threaded
., tests
Other-Modules:
WikiParserTest
- Extensions:
- Arrows
GHC-Options:
-Wall -Werror
+{-# 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
+{-# LANGUAGE
+ OverloadedStrings
+ , UnicodeSyntax
+ #-}
+-- FIXME: authentication
module Rakka.Authorization
( AuthDB
, mkAuthDB
, 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
}
-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)
+{-# 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
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"
, 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)
sysConf <- mkSystemConfig lucuConf repos
storage <- mkStorage lsdir repos (makeDraft' interpTable)
authDB <- mkAuthDB lsdir
-
return Environment {
envLocalStateDir = lsdir
, envLucuConf = lucuConf
, 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 ]
+{-# LANGUAGE
+ Arrows
+ , TypeOperators
+ , UnicodeSyntax
+ #-}
module Rakka.Page
( PageName
, 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
-- 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)
-> 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)
)) -<< ()
-> 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
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"
)
)) -<< ()
-
-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
(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
, entityRevision = undefined
, entityLastMod = undefined
, entitySummary = summary
- , entityOtherLang = M.fromList otherLang
+ , entityOtherLang = M.fromList ((CI.mk ∘ T.pack ⁂ T.pack) <$> otherLang)
, entityContent = content
, entityUpdateInfo = updateInfo
}
| 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
+ }
+{-# LANGUAGE
+ Arrows
+ , DoAndIfThenElse
+ , UnicodeSyntax
+ #-}
module Rakka.Resource
( runIdempotentA
, runIdempotentA'
, 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"
)
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))
]
-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
+{-# 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
--- -*- 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
+{-# 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
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
, 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
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
]
-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
{-
<page name="Foo/Baz" />
</pageListing>
-}
-handleGetPageListing :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a (PageName, [PageName]) (Resource ())
+handleGetPageListing ∷ (ArrowXml (⇝), ArrowChoice (⇝), ArrowIO (⇝))
+ ⇒ Environment
+ → (PageName, [PageName]) ⇝ Resource ()
handleGetPageListing env
= proc (dir, items)
- -> 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
{-
<pageNotFound name="Foo/Bar" />
-}
-handlePageNotFound :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a PageName (Resource ())
+handlePageNotFound ∷ (ArrowXml (⇝), ArrowChoice (⇝), ArrowIO (⇝))
+ ⇒ Environment
+ → PageName ⇝ Resource ()
handlePageNotFound env
= proc name
- -> 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
| 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
+{-# 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
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 ---
-> (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
+ ) ) ⤛ ()
+{-# 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
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
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
{-
<searchResult query="foo bar baz"
...
</searchResult>
-}
-handleSearch :: Environment -> Resource ()
+handleSearch ∷ Environment → Resource ()
handleSearch env
- = do params <- getQueryForm
+ = do params ← getQueryForm
let query = fromMaybe "" $ findQueryParam "q" params
order = findQueryParam "order" params
to = fromMaybe (from + resultsPerSection)
$ fmap read $ findQueryParam "to" params
- cond <- liftIO $ mkCond query order from to
- result <- searchPages (envStorage env) cond
+ cond ← liftIO $ mkCond (T.pack query) (T.pack <$> order) from to
+ result ← searchPages (envStorage env) cond
let to' = min (from + length (srPages result)) to
- 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"
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))
)
)
-- どちらにも溢れない
(windowBegin, windowBegin + windowWidth - 1)
in
- arrL id -< [begin .. end]
+ arrL id ⤙ [begin .. end]
mkSectionURI :: Arrow a => URI -> a (String, (Maybe String, Int)) URI
}
uriToText :: ArrowXml a => a URI XmlTree
- uriToText = arr (\ uri -> uriToString id uri "") >>> mkText
+ uriToText = arr (\ uri -> uriToString id uri "") ⋙ mkText
-- FIXME: localize
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
+{-# 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 ==> 全設定値を返す
, resDelete = Nothing
}
-
{-
<systemConfig>
<value path="siteName">Rakka</value>
-> 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 )
, (a_output_encoding, utf8)
, (a_no_xml_pi , v_0 ) ]
)
- output xmlStr
+ output $ UTF8.encodeString xmlStr
where
mkResponseTree :: ArrowXml a => a b XmlTree
mkResponseTree
+{-# 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
[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
< 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
+{-# 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
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
)
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
+ }
+{-# LANGUAGE
+ OverloadedStrings
+ , UnicodeSyntax
+ #-}
module Rakka.Storage.Impl
( getPage'
, putPage'
, 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
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)
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 ()
-- -*- coding: utf-8 -*-
+{-# LANGUAGE
+ DoAndIfThenElse
+ , RecordWildCards
+ , ScopedTypeVariables
+ , UnicodeSyntax
+ #-}
module Rakka.Storage.Repos
( findAllPagesInRevision
, getDirContentsInRevision
, 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
decodePath :: FilePath -> PageName
decodePath = decodePageName . makeRelative root . dropExtension
-
getDirContentsInRevision :: Repository -> PageName -> Maybe RevNum -> IO (Set PageName)
getDirContentsInRevision repos dir rev
= do fs <- getRepositoryFS repos
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
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
, 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
}
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)
}
-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
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
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
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
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
+{-# LANGUAGE
+ UnicodeSyntax
+ #-}
module Rakka.Storage.Types
( Storage(..)
, IndexReq(..)
, 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 {
, stoIndexChan :: !(TChan IndexReq)
}
-
data IndexReq
= RebuildIndex
| SyncIndex
| SearchIndex !Condition !(TMVar SearchResult)
-
data SearchResult
= SearchResult {
srTotal :: !Int
}
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)
+{-# LANGUAGE
+ DeriveDataTypeable
+ , OverloadedStrings
+ , ScopedTypeVariables
+ , UnicodeSyntax
+ #-}
module Rakka.SystemConfig
( SystemConfig
, SysConfValue(..)
, 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
import Subversion.Repository
import Subversion.Types
import System.FilePath.Posix
+import System.IO.Unsafe
import System.Log.Logger
-
logger :: String
logger = "Rakka.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
, 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
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
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
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" )
+{-# LANGUAGE
+ Arrows
+ , OverloadedStrings
+ , TypeOperators
+ , UnicodeSyntax
+ #-}
module Rakka.Utils
( yesOrNo
, trueOrFalse
, 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
+{-# 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
+-- FIXME: use time-w3c
module Rakka.W3CDateTime
( formatW3CDateTime
, parseW3CDateTime
)
where
-
import Control.Monad
import Data.Time
import Prelude hiding (min)
+{-# LANGUAGE
+ UnicodeSyntax
+ #-}
module Rakka.Wiki
( WikiPage
, 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]
}
+{-# LANGUAGE
+ Arrows
+ , OverloadedStrings
+ , ScopedTypeVariables
+ , TypeOperators
+ , UnicodeSyntax
+ #-}
module Rakka.Wiki.Engine
( InterpTable
, makeMainXHTML
, 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
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" _ _
-
-- <img src="data:image/png;base64,..." />
- -> returnA -< [ Paragraph [Image (Left $ fromJust dataURI) Nothing] ]
-
- _ -> if isJust dataURI then
-
-- <a href="data:application/zip;base64,...">
- -- application/zip
- -- </a>
- returnA -< [ Paragraph [ Anchor
- [("href", show dataURI)]
- [Text (show pType)]
- ]
- ]
- else
- -- pre
- returnA -< [ Preformatted [Text $ fromJust textData] ]
+ → do pType ← getXPathTreesInDoc "/page/@type/text()" ⋙ getText ⋙ arr read ⤙ tree
+ textData ← maybeA (getXPathTreesInDoc "/page/textData/text()" ⋙ getText) ⤙ tree
+ base64Data ← maybeA (getXPathTreesInDoc "/page/binaryData/text()" ⋙ getText) ⤙ tree
+
+ let dataURI = binToURI pType <$> base64Data
+
+ case pType of
+ MIMEType "text" "x-rakka" _
+ → case parse (wikiPage $ cmdTypeOf interpTable) "" (fromJust textData) of
+ Left err → wikifyParseError ⤙ err
+ Right xs → returnA ⤙ xs
+
+ MIMEType "image" _ _
+ -- <img src="data:image/png;base64,..." />
+ → returnA ⤙ [ Paragraph [Image (Left $ fromJust dataURI) Nothing] ]
+
+ _ → if isJust dataURI then
+ -- <a href="data:application/zip;base64,...">
+ -- application/zip
+ -- </a>
+ returnA ⤙ [ Paragraph [ Anchor
+ [("href", T.pack $ show dataURI)]
+ [Text (T.pack $ show pType)]
+ ]
+ ]
+ else
+ -- pre
+ returnA ⤙ [ Preformatted [Text ∘ T.pack $ fromJust textData] ]
where
binToURI :: MIMEType -> String -> URI
binToURI pType base64Data
| 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" _ _
- -- <img src="data:image/png;base64,..." />
- -> returnA -< [ Paragraph [Image (Left dataURI) Nothing] ]
-
-
- _
- -- <a href="data:application/zip;base64,...">
- -- application/zip (19372 bytes)
- -- </a>
- -> returnA -< [ Paragraph [ Anchor
- [("href", show dataURI)]
- [Text (show pType ++
- " (" ++
- show (Lazy.length pBin) ++
- " bytes)")]
- ]
- ]
+ → do let text = UTF8.decode $ Lazy.unpack pBin
+ dataURI = binToURI pType pBin
+
+ case pType of
+ MIMEType "text" "x-rakka" _
+ -> case parse (wikiPage $ cmdTypeOf interpTable) "" text of
+ Left err -> wikifyParseError -< err
+ Right xs -> returnA -< xs
+
+ MIMEType "image" _ _
+ -- <img src="data:image/png;base64,..." />
+ -> returnA -< [ Paragraph [Image (Left dataURI) Nothing] ]
+
+ _ -- <a href="data:application/zip;base64,...">
+ -- application/zip (19372 bytes)
+ -- </a>
+ -> returnA -< [ Paragraph [ Anchor
+ [("href", T.pack $ show dataURI)]
+ [Text (T.concat [ T.pack $ show pType
+ , "("
+ , T.pack ∘ show $ Lazy.length pBin
+ , " bytes)"
+ ])]
+ ]
+ ]
where
binToURI :: MIMEType -> Lazy.ByteString -> URI
binToURI m b
, 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) =>
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
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
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
++
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)]) ]]
+{-# 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
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" -< ()
) -< (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
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)
_ -> 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")
+{-# LANGUAGE
+ UnicodeSyntax
+ #-}
module Rakka.Wiki.Interpreter
( Interpreter(..)
, InterpreterContext(..)
, 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)
}
, 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
+{-# 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
, configurationInterp
]
-
lineBreakInterp :: Interpreter
lineBreakInterp = InlineCommandInterpreter {
iciName = "br"
= \ 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))]
-- 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
-- <input type="button"
-- value="Configuration"
-- class="configButton controls" />
-configurationInterp :: Interpreter
+configurationInterp ∷ Interpreter
configurationInterp
= InlineCommandInterpreter {
iciName = "configuration"
, iciInterpret
- = \ _ _ ->
+ = \_ _ →
let attrs = [ ("type" , "button")
, ("value", "Configuration")
, ("class", "configButton controls")
+{-# 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
]
-
-- <img src="[PageName]"
-- alt="[Alternative]" -- 省略可能
-- link="[PageName]" -- 省略可能、省略時は画像そのものへのリンク
-- <a href="..." class="inlineImage ...">
-- <img src="..." alt="..." />
-- </a>
-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
}
-- ...
-- </div>
-- </div>
-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
+{-# 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 ]
+{-# 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
-- ...
-- </ul>
-- </div>
-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
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]) ]
+ _ → []
)
+{-# 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
, 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 '-')
"description of term"
-verbatim :: Parser BlockElement
-verbatim = do _ <- try (string "<!verbatim[")
- _ <- many (oneOf " \t\n")
- x <- verbatim'
- return (Preformatted [Text x])
+verbatim ∷ Parser BlockElement
+verbatim = try (string "<!verbatim[") *>
+ many (oneOf " \t\n") *>
+ (Preformatted ∘ (:[]) ∘ Text ∘ T.pack <$> verbatim')
where
verbatim' :: Parser String
- 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
, bCmdAttributes = tagAttrs
, bCmdContents = xs
}
-
Just InlineCommandType
-> pzero
-
_ -> return $ undefinedCmdErr tagName
)
<|>
, 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
, inlineCmd cmdTypeOf
]
-
-nowiki :: Parser InlineElement
-nowiki = liftM Text (try (string "<!nowiki[") >> nowiki')
+nowiki ∷ Parser InlineElement
+nowiki = Text ∘ T.pack <$> (try (string "<!nowiki[") *> 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
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
<?>
"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 ()
+{-# 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 ""
projects / Rakka.git / commitdiff