-{-# LANGUAGE CPP #-}
+{-# LANGUAGE
+ CPP
+ , UnicodeSyntax
+ #-}
import Control.Exception
import Control.Monad
import Data.List
import Data.Maybe
-import Network.Socket
+import Network.Socket
import Network.HTTP.Lucu
- import OpenSSL
++import OpenSSL
import Rakka.Environment
import Rakka.Resource.CheckAuth
import Rakka.Resource.DumpRepos
import Rakka.Resource.Render
import Rakka.Resource.Search
import Rakka.Resource.SystemConfig
- -- import Rakka.Resource.TrackBack
import Rakka.Resource.Users
import Rakka.Storage
import Subversion
- import System.Console.GetOpt
+ import System.Console.GetOpt -- FIXME: Use better library than this.
import System.Directory
import System.Environment
import System.Exit
deriving (Eq, Show)
-defaultPort :: ServiceName
+defaultPort ∷ ServiceName
defaultPort = "8080"
defaultLocalStateDir :: FilePath
withSystemLock (lsdir </> "lock") $
withPidFile (lsdir </> "pid") $
do setupLogger opts
- env <- setupEnv lsdir portNum
+ env ← setupEnv lsdir portNum
rebuildIndexIfRequested env opts
, (["search.html" ], resSearch env)
, (["search.xml" ], resSearch env)
, (["systemConfig"], resSystemConfig env)
-- -- , (["trackback" ], resTrackBack env)
, (["users" ], resUsers env)
]
-
-getPortNum :: [CmdOpt] -> IO ServiceName
+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
Maintainer: PHO <pho at cielonegro dot org>
Stability: experimental
Homepage: http://rakka.cielonegro.org/
+ Bug-Reports: http://static.cielonegro.org/ditz/Rakka/
Category: Web
Tested-With: GHC == 6.12.1
Cabal-Version: >= 1.6
Build-Type: Custom
+
Data-Files:
defaultPages/Feed.xml
defaultPages/Help/SampleImage/Large.xml
defaultPages/StyleSheet/Default.xml
rc.d/NetBSD/rakka.in
schemas/rakka-page-1.0.rng
+
Extra-Source-Files:
Rakka.buildinfo.in
configure
Executable rakka
Build-Depends:
- ascii == 0.0.*,
- base == 4.3.*,
+ HsHyperEstraier == 0.4.*,
++ HsOpenSSL == 0.10.*,
+ HsSVN == 0.4.*,
+ Lucu == 0.7.*,
++ base == 4.*,
base-unicode-symbols == 0.2.*,
+ bytestring == 0.9.*,
+ case-insensitive == 0.4.*,
+ containers == 0.4.*,
+ dataenc == 0.14.*,
+ directory == 1.1.*,
filemanip == 0.3.*,
- text == 0.11.*,
+ filepath == 1.2.*,
+ hslogger == 1.1.*,
- hxt == 9.1.*,
++ hxt == 9.2.*,
+ hxt-relaxng == 9.1.*,
+ hxt-xpath == 9.1.*,
+ magic == 1.0.*,
+ mtl == 2.0.*,
+ network == 2.3.*,
+ parsec == 3.1.*,
+ stm == 2.2.*,
+ text == 0.11.*,
+ time == 1.2.*,
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
+ time-w3c == 0.1.*,
+ unix == 2.4.*,
++ utf8-string == 0.3.*,
+ zlib == 0.5.*
Main-Is:
Main.hs
Rakka.Resource.Render
Rakka.Resource.Search
Rakka.Resource.SystemConfig
- Rakka.Resource.TrackBack
Rakka.Resource.Users
Rakka.Storage
Rakka.Storage.DefaultPage
Rakka.Storage.Types
Rakka.Storage.Impl
Rakka.SystemConfig
- Rakka.TrackBack
Rakka.Utils
Rakka.Validation
- Rakka.W3CDateTime
Rakka.Wiki
Rakka.Wiki.Interpreter
Rakka.Wiki.Interpreter.Base
Rakka.Wiki.Interpreter.Image
Rakka.Wiki.Interpreter.PageList
- Rakka.Wiki.Interpreter.Trackback
Rakka.Wiki.Interpreter.Outline
Rakka.Wiki.Engine
Rakka.Wiki.Formatter
Executable RakkaUnitTest
if flag(build-test-suite)
Buildable: True
+ Build-Depends: HUnit
else
Buildable: False
+
Main-Is:
RakkaUnitTest.hs
+
Hs-Source-Dirs:
., tests
+
Other-Modules:
WikiParserTest
+
GHC-Options:
-Wall -Werror
+{-# 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.Socket
+import Network.Socket
import qualified Network.HTTP.Lucu.Config as LC
import Rakka.Authorization
import Rakka.Page
import qualified Rakka.Wiki.Interpreter.Base as Base
import qualified Rakka.Wiki.Interpreter.Image as Image
import qualified Rakka.Wiki.Interpreter.PageList as PageList
- --import qualified Rakka.Wiki.Interpreter.Trackback as Trackback
import qualified Rakka.Wiki.Interpreter.Outline as Outline
import Subversion.Repository
import System.Directory
import System.FilePath
import System.Log.Logger
import Text.HyperEstraier
-
+import Text.XML.HXT.Arrow.XmlState
logger :: String
logger = "Rakka.Environment"
, envAuthDB :: !AuthDB
}
-
-setupEnv :: FilePath -> ServiceName -> IO Environment
-setupEnv lsdir portNum
+setupEnv ∷ FilePath → ServiceName → IO Environment
+setupEnv lsdir port
= do let lucuConf = LC.defaultConfig {
- LC.cnfServerPort = 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 ]
--- -*- coding: utf-8 -*-
{-# LANGUAGE
Arrows
+ , TypeOperators
, UnicodeSyntax
#-}
module Rakka.Page
, parseXmlizedPage
)
where
+import Control.Applicative
import Control.Arrow
-import qualified Data.Ascii as Ascii
-import qualified Data.Text as T
+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.Char
-import Data.Map (Map)
+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.Time
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Text.Encoding
+import Data.Time
+ import qualified Data.Time.W3C as W3C
-import Network.HTTP.Lucu hiding (redirect)
-import Network.URI hiding (fragment)
-import Rakka.Utils
-import Subversion.Types
-import System.FilePath.Posix
+import Network.HTTP.Lucu hiding (redirect)
+import Network.URI hiding (fragment)
- import OpenSSL.EVP.Base64
++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.XmlArrow
import Text.XML.HXT.DOM.TypeDefs
import Text.XML.HXT.XPath
-import Text.XML.HXT.Arrow.XmlArrow
-import Prelude.Unicode
-
-type PageName = T.Text
-
-type LanguageTag = Ascii -- See RFC 3066: http://www.ietf.org/rfc/rfc3066.txt
-type LanguageName = T.Text -- 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
= Redirection {
redirName :: !PageName
}
deriving (Show, Eq)
--
data UpdateInfo
= UpdateInfo {
uiOldRevision :: !RevNum
-- 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)
-
-
-decodePageName :: FilePath -> PageName
-decodePageName = UTF8.decodeString . unEscapeString
+ fixPageName ∷ String → String
+ fixPageName = capitalizeHead ∘ map (\c → if c ≡ ' ' then '_' else c)
+ capitalizeHead ∷ String → String
+ capitalizeHead [] = (⊥)
+ capitalizeHead (x:xs) = toUpper x : xs
-encodeFragment :: String -> String
-encodeFragment = escapeURIString isSafeChar . UTF8.encodeString
+-- FIXME: use system-filepath
+decodePageName ∷ FilePath → PageName
+decodePageName = T.pack ∘ UTF8.decodeString ∘ unEscapeString
+encodeFragment ∷ Text → String
+encodeFragment = escapeURIString isSafeChar ∘ B8.unpack ∘ encodeUtf8
-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)
+ += sattr "lastModified" (W3C.format lastMod)
)) -<< ()
xmlizeEntity :: (ArrowXml a, ArrowChoice a, ArrowIO a) => a Page XmlTree
-> 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
+= sattr "isLocked" (yesOrNo $ entityIsLocked page)
+= sattr "isBinary" (yesOrNo $ entityIsBinary page)
+= sattr "revision" (show $ entityRevision page)
- += sattr "lastModified" (formatW3CDateTime lastMod)
+ += sattr "lastModified" (W3C.format lastMod)
+= ( case entitySummary page of
Just s -> eelem "summary" += txt s
Nothing -> none
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
}
- where
- dropWhitespace :: String -> String
- dropWhitespace [] = []
- dropWhitespace (x:xs)
- | x == ' ' || x == '\t' || x == '\n'
- = dropWhitespace xs
- | otherwise
- = x : dropWhitespace xs
-
-parseUpdateInfo :: (ArrowXml a, ArrowChoice a) => a 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
- }
+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 = T.pack <$> oldName
+ }
++
+ dropWhitespace :: String -> String
+ {-# INLINE dropWhitespace #-}
+ dropWhitespace = filter ((¬) ∘ isSpace)
+{-# 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 qualified Data.Time.W3C as W3C
import Network.HTTP.Lucu
import Network.URI hiding (path)
+import Prelude.Unicode
import Rakka.Environment
import Rakka.Page
import Rakka.Resource
import Rakka.Storage
import Rakka.SystemConfig
import Rakka.Utils
- import Rakka.W3CDateTime
import Rakka.Wiki.Engine
import System.FilePath.Posix
import Text.HyperEstraier hiding (getText)
-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 W3C.format
- >>>
- 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
++ arr W3C.format
+ ⋙
+ 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
+ , 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 qualified Data.ByteString.Char8 as C8
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 qualified Data.Time.W3C as W3C
import Network.HTTP.Lucu
import Network.URI hiding (query, fragment)
+import Prelude.Unicode
import Rakka.Environment
import Rakka.Page
import Rakka.Resource
import Rakka.Storage
import Rakka.SystemConfig
import Rakka.Utils
- import Rakka.W3CDateTime
import Rakka.Wiki.Engine
import System.FilePath
import Text.HyperEstraier hiding (getText)
-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
+ arr W3C.format
- >>>
+ ⋙
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)
+ arr (zonedTimeToUTC . fromJust . W3C.parse)
- >>>
+ ⋙
arrIO utcToLocalZonedTime
- >>>
+ ⋙
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
= arr $ \ (query, (order, section))
-> baseURI {
uriPath = uriPath baseURI </> "search.html"
-- , uriQuery = '?' : mkQueryString ( [ ("q" , query)
-- , ("from", show $ section * resultsPerSection)
-- , ("to" , show $ (section + 1) * resultsPerSection - 1)
-- ]
-- ++
-- case order of
-- Just o -> [("order", o)]
-- Nothing -> []
-- )
++ , uriQuery = '?' : C8.unpack (mkQueryString ( [ ("q" , T.pack query)
++ , ("from", T.pack ∘ show $ section ⋅ resultsPerSection )
++ , ("to" , T.pack ∘ show $ (section + 1) ⋅ resultsPerSection - 1)
++ ]
++ ++
++ case order of
++ Just o -> [("order", T.pack o)]
++ Nothing -> []
++ ))
}
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
+++ /dev/null
--module Rakka.Resource.TrackBack
-- ( resTrackBack
-- )
-- where
--
--import qualified Codec.Binary.UTF8.String as UTF8
--import Control.Arrow
--import Control.Arrow.ArrowList
--import Control.Monad.Trans
--import Data.List
--import Data.Maybe
--import Data.Time
--import Network.Browser
--import Network.HTTP
--import Network.HTTP.Lucu
--import Network.HTTP.Lucu.Response
--import Network.URI
--import Rakka.Environment
--import Rakka.Page
--import Rakka.Storage
--import Rakka.SystemConfig
--import Rakka.TrackBack
--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
--
--
--data TBResponse
-- = NoError
-- | Error !Int !String
-- deriving (Show, Eq)
--
--
--resTrackBack :: Environment -> ResourceDef
--resTrackBack env
-- = ResourceDef {
-- resUsesNativeThread = False
-- , resIsGreedy = True
-- , resGet = Nothing
-- , resHead = Nothing
-- , resPost = Just $ getPathInfo >>= handlePost env . toPageName
-- , resPut = Nothing
-- , resDelete = Nothing
-- }
-- where
-- toPageName :: [String] -> PageName
-- toPageName = UTF8.decodeString . joinPath
--
--
--handlePost :: Environment -> PageName -> Resource ()
--handlePost env name
-- = do form <- inputForm defaultLimit
-- tbParamM <- validateTrackBack form
-- case tbParamM of
-- Nothing
-- -> return ()
-- Just tbParam
-- -> do cited <- liftIO $ checkCitation tbParam name
-- if cited then
-- do pageM <- getPage (envStorage env) name Nothing
-- case pageM of
-- Nothing -> setStatus NotFound
-- Just page -> addTB tbParam page
-- else
-- outputResponse (Error 1 "Failed to confirm if your entry contains any citation to this page.")
-- where
-- addTB :: TrackBack -> Page -> Resource ()
-- addTB tbParam page
-- | isRedirect page
-- = do BaseURI baseURI <- getSysConf (envSysConf env)
-- redirect TemporaryRedirect (mkPageURI baseURI $ redirName page)
-- | otherwise
-- = do tbListM <- return . fromMaybe [] =<< getAttachment (envStorage env) (pageName page) "trackbacks" Nothing
-- st <- putAttachment (envStorage env) Nothing Nothing (pageName page) "trackbacks" (tbParam : tbListM)
-- if isSuccessful st then
-- outputResponse NoError
-- else
-- setStatus st
--
--
--validateTrackBack :: [(String, String)] -> Resource (Maybe TrackBack)
--validateTrackBack form
-- = do let title = get' "title"
-- excerpt = get' "excerpt"
-- blogName = get' "blog_name"
-- case get' "url" of
-- Nothing
-- -> do outputResponse (Error 1 "Parameter `url' is missing.")
-- return Nothing
-- Just u
-- -> case parseURI u of
-- Nothing
-- -> do outputResponse (Error 1 "Parameter `url' is malformed.")
-- return Nothing
-- Just url
-- -> do time <- liftIO getCurrentTime
-- return $ Just TrackBack {
-- tbTitle = title
-- , tbExcerpt = excerpt
-- , tbURL = url
-- , tbBlogName = blogName
-- , tbTime = time
-- }
-- where
-- get' :: String -> Maybe String
-- get' = fmap UTF8.decodeString . flip lookup form
--
--
--outputResponse :: TBResponse -> Resource ()
--outputResponse res
-- = do setContentType $ read "text/xml"
-- [xmlStr] <- liftIO $ runX ( setErrorMsgHandler False fail
-- >>>
-- mkResponseTree
-- >>>
-- writeDocumentToString [ (a_indent , v_1 )
-- , (a_output_encoding, utf8)
-- , (a_no_xml_pi , v_0 ) ]
-- )
- output $ UTF8.encodeString xmlStr
- output xmlStr
-- where
-- mkResponseTree :: ArrowXml a => a b XmlTree
-- mkResponseTree
-- = proc _
-- -> ( eelem "/"
-- += ( eelem "response"
-- += ( eelem "error"
-- += txt (case res of
-- NoError -> "0"
-- Error code _ -> show code)
-- )
-- += ( case res of
-- NoError -> none
-- Error _ msg -> ( eelem "message"
-- += txt msg
-- )
-- )
-- )
-- ) -< ()
--
--
--checkCitation :: TrackBack -> PageName -> IO Bool
--checkCitation param name
-- = do (_, res) <- browse $
-- do setAllowRedirects True
-- setErrHandler (\ _ -> return ())
-- setOutHandler (\ _ -> return ())
-- request $ defaultGETRequest $ tbURL param
-- case rspCode res of
-- (2, 0, 0)
-- -> return (encodePageName name `isInfixOf` rspBody res)
-- _ -> return False
+{-# 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 qualified Data.Time.W3C as W3C
import Network.HTTP.Lucu
import Network.HTTP.Lucu.Utils
import Network.URI
import Prelude hiding (words)
+import Prelude.Unicode
import Rakka.Attachment
import Rakka.Page
import Rakka.Storage.DefaultPage
import Rakka.Storage.Repos
import Rakka.Storage.Types
- import Rakka.W3CDateTime
import Subversion.Types
import Subversion.FileSystem
import Subversion.Repository
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 . W3C.parse . 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
++ zonedTimeToUTC ∘ fromJust ∘ W3C.parse ∘ 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 qualified Data.Time.W3C as W3C
import Network.HTTP.Lucu hiding (redirect)
+import Prelude.Unicode
import Rakka.Attachment
import Rakka.Page
import Rakka.SystemConfig
import Rakka.Utils
- import Rakka.W3CDateTime
import Subversion.FileSystem
import Subversion.FileSystem.DirEntry
import Subversion.FileSystem.Revision
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
$ fmap chomp (lookup "svn:mime-type" props)
lastMod <- unsafeIOToFS $
- liftM (fromJust . parseW3CDateTime . chomp . fromJust)
+ liftM (fromJust . W3C.parse . chomp . fromJust)
(getRevisionProp' fs pageRev "svn:date")
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)
+ liftM (fromJust . W3C.parse . chomp . fromJust)
(getRevisionProp' fs pageRev "svn:date")
isLocked <- liftM isJust (getNodeProp path "rakka:isLocked")
}
-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
+ 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.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.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 = unsafePerformIO ∘ getServicePortNumber $ LC.cnfServerPort conf
+ port = unsafePerformIO $
+ do ent <- getServiceByName (LC.cnfServerPort conf) "tcp"
+ return (servicePort ent)
+ -- FIXME: There should be a way to change configurations
+ -- without web interface nor direct repository
+ -- modification.
defaultURI
- = "http://" ++ host ++ -- FIXME: consider IPv6 address
- = "http://" ++ host ++
++ = "http://" ++ host ++
(if port == 80
then ""
else ':' : show port) ++ "/"
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" )
+++ /dev/null
--module Rakka.TrackBack
-- ( TrackBack(..)
-- )
-- where
--
--import Data.Maybe
--import Data.Time
--import Network.URI
--import Rakka.Attachment
--import Rakka.Utils
--import Rakka.W3CDateTime
--import Text.XML.HXT.Arrow
--import Text.XML.HXT.DOM.TypeDefs
--
--
--data TrackBack
-- = TrackBack {
-- tbTitle :: !(Maybe String)
-- , tbExcerpt :: !(Maybe String)
-- , tbURL :: !URI
-- , tbBlogName :: !(Maybe String)
-- , tbTime :: !UTCTime
-- }
-- deriving (Show, Eq)
--
--
--{-
-- <trackbacks>
-- <trackback title="" url="" blogName="" time="">
-- excerpt...
-- </trackback>
-- ...
-- </trackbacks>
---}
--instance Attachment [TrackBack] where
-- serializeToXmlTree
-- = proc trackbacks
-- -> ( eelem "/"
-- += ( eelem "trackbacks"
-- += ( arrL id
-- >>>
-- tbToTree
-- )
-- )
-- ) -< trackbacks
-- where
-- tbToTree :: ArrowXml a => a TrackBack XmlTree
-- tbToTree
-- = proc tb
-- -> let title = case tbTitle tb of
-- Nothing -> none
-- Just t -> sattr "title" t
-- excerpt = case tbExcerpt tb of
-- Nothing -> none
-- Just e -> txt e
-- url = sattr "url" (uriToString id (tbURL tb) "")
-- blogName = case tbBlogName tb of
-- Nothing -> none
-- Just n -> sattr "blogName" n
-- time = sattr "time" (formatW3CDateTime $ utcToZonedTime utc (tbTime tb))
-- in
-- ( eelem "trackback"
-- += title
-- += url
-- += blogName
-- += time
-- += excerpt
-- ) -<< ()
--
-- deserializeFromXmlTree
-- = proc doc -> listA (getXPathTreesInDoc "/trackbacks/trackback" >>> treeToTb) -< doc
-- where
-- treeToTb :: (ArrowChoice a, ArrowXml a) => a XmlTree TrackBack
-- treeToTb
-- = proc tree
-- -> do title <- maybeA (getAttrValue0 "title") -< tree
-- url <- ( getAttrValue0 "url"
-- >>>
-- arr (fromJust . parseURI)
-- ) -< tree
-- time <- ( getAttrValue0 "time"
-- >>>
-- arr (zonedTimeToUTC . fromJust . parseW3CDateTime)
-- ) -< tree
-- blogName <- maybeA (getAttrValue0 "blogName") -< tree
-- excerpt <- maybeA ( getChildren
-- >>>
-- getText
-- ) -< tree
-- returnA -< TrackBack {
-- tbTitle = title
-- , tbExcerpt = excerpt
-- , tbURL = url
-- , tbBlogName = blogName
-- , tbTime = time
-- }
{-# LANGUAGE
Arrows
+ , OverloadedStrings
+ , TypeOperators
, UnicodeSyntax
#-}
module Rakka.Utils
, deleteIfEmpty
, chomp
, guessMIMEType
+ , isSafeChar
, 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 Control.Arrow
+ import Control.Arrow.ArrowList
-import Data.Ascii (Ascii)
-import qualified Data.Ascii as A
++import Data.ByteString (ByteString)
+ import qualified Data.ByteString as BS
+ import qualified Data.ByteString.Char8 as C8
-import qualified Data.ByteString.Unsafe as BS
+ import qualified Data.ByteString.Lazy as LS
++import qualified Data.ByteString.Unsafe as BS
+ import Data.Char
-import qualified Data.Text as T
+import Data.Monoid.Unicode
+import Data.String
- import Magic
- import Network.HTTP.Lucu
- import Network.URI
++import Data.Text (Text)
+ import Data.Text.Encoding
+ import Magic
+ import Network.HTTP.Lucu
+ import Network.URI
+ import Numeric
import Prelude.Unicode
- import System.IO.Unsafe
+ import System.IO.Unsafe
yesOrNo ∷ Bool → String
yesOrNo True = "yes"
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)
++parseYesOrNo = arr f
++ where
++ f "yes" = True
++ f "no" = False
++ f str = error ("Expected yes or no: " ⊕ show str)
- maybeA :: (ArrowList a, ArrowChoice a) => a b c -> a b (Maybe c)
+ maybeA ∷ (ArrowList a, ArrowChoice a) ⇒ a b c → a b (Maybe c)
maybeA a = listA a
>>>
- proc xs -> case xs of
- [] -> returnA -< Nothing
- (x:_) -> returnA -< Just x
-
+ proc xs → case xs of
+ [] → returnA ⤙ Nothing
+ (x:_) → returnA ⤙ Just x
- deleteIfEmpty :: (ArrowList a, ArrowChoice a) => a String String
+ deleteIfEmpty ∷ (ArrowList a, ArrowChoice a) ⇒ a String String
deleteIfEmpty
- = proc str -> do case str of
- "" -> none -< ()
- _ -> returnA -< str
-
+ = proc str → do case str of
+ "" → none ⤙ ()
+ _ → returnA ⤙ str
- chomp :: String -> String
- chomp = reverse . snd . break (/= '\n') . reverse
+ chomp ∷ String → String
+ {-# INLINE chomp #-}
+ chomp = reverse . snd . break (≢ '\n') . reverse
-
- guessMIMEType :: Lazy.ByteString -> MIMEType
- guessMIMEType = read . unsafePerformIO . magicString magic . L8.unpack
+ guessMIMEType ∷ LS.ByteString → MIMEType
+ {-# INLINEABLE guessMIMEType #-}
+ guessMIMEType = read
+ ∘ unsafePerformIO
+ ∘ flip BS.unsafeUseAsCStringLen (magicCString magic)
+ ∘ BS.concat
+ ∘ LS.toChunks
where
- magic :: Magic
+ magic ∷ Magic
+ {-# NOINLINE magic #-}
magic = unsafePerformIO
- $ do m <- magicOpen [MagicMime]
+ $ do m ← magicOpen [MagicMime]
magicLoadDefault m
return m
-
- isSafeChar :: Char -> Bool
-{-
+ isSafeChar ∷ Char → Bool
+ {-# INLINEABLE isSafeChar #-}
isSafeChar c
- | c == '/' = True
- | isReserved c = False
- | c > ' ' && c <= '~' = True
- | otherwise = False
+ | c ≡ '/' = True
+ | isReserved c = False
+ | c > ' ' ∧ c ≤ '~' = True
+ | otherwise = False
--}
-mkQueryString ∷ [(T.Text, T.Text)] → Ascii
++mkQueryString ∷ [(Text, Text)] → ByteString
+ {-# INLINEABLE mkQueryString #-}
-mkQueryString = A.unsafeFromByteString
- ∘ BS.intercalate (C8.singleton ';')
- ∘ map encodePair
++mkQueryString = BS.intercalate (C8.singleton ';') ∘ map encodePair
+ where
- encodePair ∷ (T.Text, T.Text) → BS.ByteString
++ encodePair ∷ (Text, Text) → ByteString
+ {-# INLINE encodePair #-}
+ encodePair (k, v)
+ = BS.intercalate (C8.singleton '=') [encodeText k, encodeText v]
+
- encodeText ∷ T.Text → BS.ByteString
++ encodeText ∷ Text → ByteString
+ {-# INLINE encodeText #-}
+ encodeText = toURLEncoded ∘ encodeUtf8
- mkQueryString :: [(String, String)] -> String
- mkQueryString [] = ""
- mkQueryString ((k, v) : xs) = encode k ++ "=" ++ encode v ++
- if xs == [] then
- ""
- else
- ';' : mkQueryString(xs)
-toURLEncoded ∷ BS.ByteString → BS.ByteString
++toURLEncoded ∷ ByteString → ByteString
+ {-# INLINEABLE toURLEncoded #-}
+ toURLEncoded = C8.concatMap go
where
- encode :: String -> String
- encode = escapeURIString isSafeChar . UTF8.encodeString
- go ∷ Char → BS.ByteString
++ go ∷ Char → ByteString
+ {-# INLINE go #-}
+ go c | c ≡ ' ' = C8.singleton '+'
+ | isReserved c = urlEncode c
+ | isUnreserved c = C8.singleton c
+ | otherwise = urlEncode c
+
- urlEncode ∷ Char → BS.ByteString
++ urlEncode ∷ Char → ByteString
+ {-# INLINE urlEncode #-}
+ urlEncode c = C8.pack ('%':toHex (ord c))
+
+ toHex ∷ Int → String
+ {-# INLINE toHex #-}
+ toHex n
+ = case showIntAtBase 16 toChrHex n "" of
+ [] → "00"
+ [c] → ['0', c]
+ cs → cs
+
+ toChrHex ∷ Int → Char
+ {-# INLINE toChrHex #-}
+ toChrHex d
+ | d < 10 = chr (ord '0' + fromIntegral d )
+ | otherwise = chr (ord 'A' + fromIntegral (d-10))
+{-# LANGUAGE
+ OverloadedStrings
+ , RecordWildCards
+ , UnicodeSyntax
+ #-}
module Rakka.Wiki.Interpreter.PageList
( interpreters
)
where
-
-import Control.Monad
-import Data.Maybe
+import Control.Applicative
+import Control.Monad
++import qualified Data.ByteString.Char8 as C8
+import Data.Maybe
+import Data.Monoid.Unicode
+import qualified Data.Text as T
import Data.Time
import qualified Data.Time.RFC1123 as RFC1123
import Network.URI
+import Prelude.Unicode
import Rakka.Storage
import Rakka.SystemConfig
import Rakka.Utils
= \ ctx _ -> do BaseURI baseURI <- getSysConf (ctxSysConf ctx)
let uri = baseURI {
uriPath = uriPath baseURI </> "search.html"
-- , uriQuery = '?' : mkQueryString [ ("q" , "[UVSET]")
-- , ("order", "@mdate NUMD")
-- ]
++ , uriQuery = '?' : C8.unpack (mkQueryString [ ("q" , "[UVSET]")
++ , ("order", "@mdate NUMD")
++ ])
}
return $ ExternalLink uri (Just "List all pages")
}
-- ...
-- </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 (RFC1123.format lastMod))]
+ [Inline (Text (T.pack $ RFC1123.format lastMod))]
)
]
- ++
+ ⊕
case (showSummary, hpSummary page) of
(True, Just s)
- -> [ Block (Paragraph [Text s]) ]
- _ -> []
+ → [ Block (Paragraph [Text s]) ]
+ _ → []
)
+++ /dev/null
--module Rakka.Wiki.Interpreter.Trackback
-- ( interpreters
-- )
-- where
--
--import Data.Maybe
--import Data.Time
--import Network.HTTP.Lucu.RFC1123DateTime
--import Rakka.Page
--import Rakka.Storage
--import Rakka.SystemConfig
--import Rakka.TrackBack
--import Rakka.Wiki
--import Rakka.Wiki.Interpreter
--
--
--interpreters :: [Interpreter]
--interpreters = [ trackbackURLInterp
-- , trackbacksInterp
-- ]
--
--
--trackbackURLInterp :: Interpreter
--trackbackURLInterp
-- = InlineCommandInterpreter {
-- iciName = "trackbackURL"
-- , iciInterpret
-- = \ ctx _ -> case ctxPageName ctx of
-- Nothing
-- -> return (Text "No trackbacks for this page.")
-- Just name
-- -> do BaseURI baseURI <- getSysConf (ctxSysConf ctx)
-- let uri = mkAuxiliaryURI baseURI ["trackback"] name
-- return $ ExternalLink uri (Just "Trackback URL")
-- }
--
--
--trackbacksInterp :: Interpreter
--trackbacksInterp
-- = BlockCommandInterpreter {
-- bciName = "trackbacks"
-- , bciInterpret
-- = \ ctx _ ->
-- do trackbacks <- case ctxPageName ctx of
-- Nothing
-- -> return []
-- Just name
-- -> liftM (fromMaybe [])
-- (getAttachment (ctxStorage ctx) name "trackbacks" Nothing)
-- items <- mapM mkListItem trackbacks
--
-- let divElem = Div [("class", "trackbacks")] [list]
-- list = Block (List Bullet items)
--
-- return divElem
-- }
-- where
-- mkListItem :: TrackBack -> IO ListItem
-- mkListItem tb
-- = do zonedTime <- utcToLocalZonedTime (tbTime tb)
--
-- let anchor = Just (Inline (ExternalLink (tbURL tb) label))
-- label = case (tbTitle tb, tbBlogName tb) of
-- (Nothing , Nothing ) -> Nothing
-- (Just title, Nothing ) -> Just title
-- (Nothing , Just blogName) -> Just blogName
-- (Just title, Just blogName) -> Just (title ++ " (" ++ blogName ++ ")")
-- date = Just ( Block ( Div [("class", "date")]
-- [Inline (Text (formatRFC1123DateTime zonedTime))]
-- )
-- )
-- excerpt = do e <- tbExcerpt tb
-- return $ Block $ Paragraph [Text e]
--
-- return $ catMaybes [anchor, date, excerpt]
+{-# 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
ys <- (paragraph' <|> return [])
return (Text "\n" : ys)
-- \n があり、その次に \n または
- -- blockSymbols があれば、fail して
- -- 最初の newline を讀んだ所まで卷き
- -- 戻す。
-
- -- FIXME: 本當にそのやうな動作になつ
- -- てゐるか？偶然動いてゐるだけではな
- -- いか？確かにこの實裝でユニットテス
- -- トは通るのだが、私の理解を越えてし
- -- まったやうだ。
+ -- blockSymbols があれば、fail して最
+ -- 初の newline を讀んだ所まで卷き戻
+ -- す。oneOf が一文字消費しているので、
+ -- <|> は右辺を適用せずに try まで戻
+ -- る。
)
<|>
paragraph'
, 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 ()
text-indent: 0;
}
--.sideBar .recentUpdates p,
--.sideBar .trackbacks p {
++.sideBar .recentUpdates p {
font-size: 90%;
}
text-indent: 0;
}
--.sideBar .recentUpdates p,
--.sideBar .trackbacks p {
++.sideBar .recentUpdates p {
font-size: 90%;
}
-moz-border-radius: 10px;
}
--.sideBar .recentUpdates li, .sideBar .trackbacks li {
++.sideBar .recentUpdates li {
background-color: #e0e0e0;
}
projects / Rakka.git / commitdiff