import System.Posix.Types
import System.Posix.User
+
+logger :: String
logger = "Main"
GHC = ghc
EXECUTABLE = sudo ./dist/build/rakka/rakka -p 8989 -l DEBUG
-build: .setup-config Setup
+build: dist/setup-config Setup
$(MAKE) -C js $@
./Setup build
rebuild-index: build
$(EXECUTABLE) --rebuild-index
-.setup-config: $(CABAL_FILE) configure Setup Rakka.buildinfo.in
- BUILD_TEST_SUITE=yes ./Setup configure
+dist/setup-config: $(CABAL_FILE) configure Setup Rakka.buildinfo.in
+ ./Setup configure --disable-optimization -fbuild-test-suite
+# ./Setup configure -O
configure: configure.ac
autoconf
$(GHC) --make Setup
clean:
- rm -rf dist Setup Setup.o Setup.hi .setup-config
+ $(MAKE) -C js $@
+ rm -rf dist Setup Setup.o Setup.hi
find . -name '*~' -exec rm -f {} \;
install: build
sdist: Setup
./Setup sdist
-.PHONY: build run clean install doc sdist
\ No newline at end of file
+.PHONY: build run clean install doc sdist
-- -*- haskell-cabal -*-
-Executable:
- rakka
+Executable: rakka
GHC-Options:
-DLOCALSTATEDIR="@RAKKA_LOCALSTATEDIR@"
-
-Executable:
- RakkaUnitTest
-Buildable:
- @BUILD_TEST_SUITE@
-Name:
- Rakka
-Synopsis:
- Wiki engine with Subversion backend
+Name: Rakka
+Synopsis: Wiki engine with Subversion backend
Description:
FIXME: write this
-Version:
- 0.1
-License:
- PublicDomain
-Author:
- PHO <phonohawk at ps dot sakura dot ne dot jp>
-Maintainer:
- PHO <phonohawk at ps dot sakura dot ne dot jp>
-Stability:
- experimental
-Homepage:
- http://ccm.sherry.jp/Rakka/
-Category:
- Web
-Tested-With:
- GHC == 6.6.1
-Build-Depends:
- Crypto, FileManip, HUnit, HsHyperEstraier >= 0.2, HsSVN, Lucu,
- base, encoding, filepath, hslogger, hxt, mtl, network, parsec,
- stm, unix, zlib
+Version: 0.1
+License: PublicDomain
+Author: PHO <phonohawk at ps dot sakura dot ne dot jp>
+Maintainer: PHO <phonohawk at ps dot sakura dot ne dot jp>
+Stability: experimental
+Homepage: http://ccm.sherry.jp/Rakka/
+Category: Web
+Tested-With: GHC == 6.6.1
+Cabal-Version: >= 1.2
+
Data-Files:
defaultpages/Help/SampleImage/Large
defaultpages/Help/SampleImage/Small
defaultPages/SideBar/Right
defaultPages/StyleSheet/Default
schemas/rakka-page-1.0.rng
+
Extra-Source-Files:
Rakka.buildinfo.in
configure
js/jquery-dom.js
js/screen.js
+Flag build-test-suite
+ Description: Build the test suite.
+ Default: False
-Executable:
- rakka
-Main-Is:
- Main.hs
-Other-Modules:
- Rakka.Environment
- Rakka.Page
- Rakka.Resource
- Rakka.Resource.Index
- Rakka.Resource.JavaScript
- Rakka.Resource.Object
- Rakka.Resource.PageEntity
- Rakka.Storage
- Rakka.Storage.DefaultPage
- Rakka.Storage.Types
- Rakka.Storage.Impl
- Rakka.SystemConfig
- Rakka.Utils
- 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
- Rakka.Wiki.Parser
-Extensions:
- Arrows, ExistentialQuantification
-GHC-Options:
- -fwarn-unused-imports -fglasgow-exts
-
+Executable rakka
+ Build-Depends:
+ Crypto, FileManip, HUnit, HsHyperEstraier, HsSVN, Lucu, base,
+ bytestring, containers, directory, utf8-string, filepath,
+ hslogger, hxt, mtl, network, parsec, stm, time, unix, zlib
+ Main-Is:
+ Main.hs
+ Other-Modules:
+ Rakka.Environment
+ Rakka.Page
+ Rakka.Resource
+ Rakka.Resource.Index
+ Rakka.Resource.JavaScript
+ Rakka.Resource.Object
+ Rakka.Resource.PageEntity
+ Rakka.Storage
+ Rakka.Storage.DefaultPage
+ Rakka.Storage.Types
+ Rakka.Storage.Impl
+ Rakka.SystemConfig
+ Rakka.Utils
+ 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
+ Rakka.Wiki.Parser
+ Extensions:
+ Arrows, ExistentialQuantification, ScopedTypeVariables
+ GHC-Options:
+ -Wall -Werror -XDeriveDataTypeable
-Executable:
- RakkaUnitTest
-Main-Is:
- RakkaUnitTest.hs
-Hs-Source-Dirs:
- tests
-Other-Modules:
- WikiParserTest
-GHC-Options:
- -fwarn-unused-imports -fglasgow-exts
\ No newline at end of file
+Executable RakkaUnitTest
+ if flag(build-test-suite)
+ Buildable: True
+ else
+ Buildable: False
+ Main-Is:
+ RakkaUnitTest.hs
+ Hs-Source-Dirs:
+ ., tests
+ Other-Modules:
+ WikiParserTest
+ GHC-Options:
+ -Wall -Werror
\ No newline at end of file
import Text.XML.HXT.Arrow.XmlIOStateArrow
+logger :: String
logger = "Rakka.Environment"
)
where
-import Data.ByteString.Base (LazyByteString)
-import qualified Data.ByteString.Char8 as C8
+import Codec.Binary.UTF8.String
+import qualified Data.ByteString.Lazy as Lazy (ByteString)
import Data.Char
-import Data.Encoding
-import Data.Encoding.UTF8
import Data.Map (Map)
import Data.Maybe
+import Data.Time
import Network.HTTP.Lucu
-import Network.URI
+import Network.URI hiding (fragment)
import Subversion.Types
import System.FilePath.Posix
-import System.Time
type PageName = String
redirName :: !PageName
, redirDest :: !PageName
, redirRevision :: !(Maybe RevNum)
- , redirLastMod :: !CalendarTime
+ , redirLastMod :: !UTCTime
}
| Entity {
pageName :: !PageName
, pageIsBoring :: !Bool
, pageIsBinary :: !Bool
, pageRevision :: !RevNum
- , pageLastMod :: !CalendarTime
+ , pageLastMod :: !UTCTime
, pageSummary :: !(Maybe String)
, pageOtherLang :: !(Map LanguageTag PageName)
- , pageContent :: !LazyByteString
+ , pageContent :: !Lazy.ByteString
}
-- UTF-8 に encode してから 0x20 - 0x7E の範圍を除いて URI escape する。
encodePageName :: PageName -> FilePath
-encodePageName = escapeURIString isSafeChar . C8.unpack . encode UTF8 . fixPageName
+encodePageName = escapeURIString isSafeChar . encodeString . fixPageName
where
fixPageName :: PageName -> PageName
fixPageName = (\ (x:xs) -> toUpper x : xs) . map (\ c -> if c == ' ' then '_' else c)
-- URI unescape して UTF-8 から decode する。
decodePageName :: FilePath -> PageName
-decodePageName = decode UTF8 . C8.pack . unEscapeString
+decodePageName = decodeString . unEscapeString
encodeFragment :: String -> String
-encodeFragment = escapeURIString isSafeChar . C8.unpack . encode UTF8
+encodeFragment = escapeURIString isSafeChar . encodeString
pageFileName' :: Page -> String
import Control.Monad.Trans
import Network.HTTP.Lucu
import Network.HTTP.Lucu.Utils
-import Network.URI
+import Network.URI hiding (path)
import Text.XML.HXT.Arrow.WriteDocument
import Text.XML.HXT.Arrow.XmlIOStateArrow
import Text.XML.HXT.DOM.TypeDefs
let formatter = case mType of
MIMEType "application" "xhtml+xml" _ -> toXHTML
MIMEType "text" "xml" _ -> this
+ _ -> undefined
[resultStr] <- liftIO $ runX ( setErrorMsgHandler False fail
>>>
constA tree
+-- -*- Coding: utf-8 -*-
module Rakka.Resource.Object
( resObject
)
import Rakka.Page
import Rakka.Storage
import Rakka.SystemConfig
-import System.Time
resObject :: Environment -> ResourceDef
-> handleRedirect env redir
Just entity@(Entity _ _ _ _ _ _ _ _ _ _ _ _ _ _)
- -> handleGetEntity env entity
+ -> handleGetEntity entity
{-
...
-}
-handleGetEntity :: Environment -> Page -> Resource ()
-handleGetEntity env page
- = do let lastMod = toClockTime $ pageLastMod page
-
- case pageRevision page of
- 0 -> foundTimeStamp lastMod -- 0 はデフォルトページ
- rev -> foundEntity (strongETag $ show rev) lastMod
+handleGetEntity :: Page -> Resource ()
+handleGetEntity page
+ = do case pageRevision page of
+ 0 -> foundTimeStamp (pageLastMod page) -- 0 はデフォルトページ
+ rev -> foundEntity (strongETag $ show rev) (pageLastMod page)
setContentType (pageType page)
setHeader (C8.pack "Content-Disposition")
import Data.Maybe
import Network.HTTP.Lucu
import Network.HTTP.Lucu.Utils
-import Network.URI
+import Network.URI hiding (path)
import Rakka.Environment
import Rakka.Page
import Rakka.Resource
import Rakka.SystemConfig
import Rakka.Wiki.Engine
import System.FilePath
-import System.Time
import Text.XML.HXT.Arrow.XmlArrow
import Text.XML.HXT.Arrow.XmlNodeSet
import Text.XML.HXT.DOM.TypeDefs
handleGetEntity env
= proc page
-> do tree <- xmlizePage -< page
- returnA -< do let lastMod = toClockTime $ pageLastMod page
-
- -- text/x-rakka の場合は、内容が動的に生成され
+ returnA -< do -- text/x-rakka の場合は、内容が動的に生成され
-- てゐる可能性があるので、ETag も
-- Last-Modified も返す事が出來ない。
case pageType page of
MIMEType "text" "x-rakka" _
-> return ()
_ -> case pageRevision page of
- 0 -> foundTimeStamp lastMod -- 0 はデフォルトページ
- rev -> foundEntity (strongETag $ show rev) lastMod
+ 0 -> foundTimeStamp (pageLastMod page) -- 0 はデフォルトページ
+ rev -> foundEntity (strongETag $ show rev) (pageLastMod page)
outputXmlPage tree (entityToXHTML env)
BaseURI baseURI <- getSysConfA (envSysConf env) -< ()
StyleSheet styleSheet <- getSysConfA (envSysConf env) -< ()
- pageName <- (getXPathTreesInDoc "/page/@name/text()" >>> getText) -< page
+ name <- (getXPathTreesInDoc "/page/@name/text()" >>> getText) -< page
let cssHref = [uriToString id (mkObjectURI baseURI styleSheet) ""]
scriptSrc = [uriToString id (baseURI { uriPath = uriPath baseURI </> "js" }) ""]
- pageTitle <- listA (readSubPage env) -< (pageName, Just page, "PageTitle")
- leftSideBar <- listA (readSubPage env) -< (pageName, Just page, "SideBar/Left")
- rightSideBar <- listA (readSubPage env) -< (pageName, Just page, "SideBar/Right")
+ 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 "/"
BaseURI baseURI <- getSysConfA (envSysConf env) -< ()
StyleSheet styleSheet <- getSysConfA (envSysConf env) -< ()
- pageName <- (getXPathTreesInDoc "/pageNotFound/@name/text()" >>> getText) -< pageNotFound
+ 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) -< (pageName, Nothing, "PageTitle")
- leftSideBar <- listA (readSubPage env) -< (pageName, Nothing, "SideBar/Left")
- rightSideBar <- listA (readSubPage env) -< (pageName, Nothing, "SideBar/Right")
+ 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"
handlePut :: Environment -> PageName -> Resource ()
-handlePut env name
+handlePut _env _name
= do xml <- input defaultLimit
setContentType $ read "text/xml"
output xml
import Subversion.Repository
import Text.HyperEstraier hiding (WriteLock)
-logger = "Rakka.Storage"
-
mkStorage :: FilePath -> Repository -> (Page -> IO Document) -> IO Storage
mkStorage lsdir repos mkDraft
putPage :: MonadIO m => Storage -> Page -> RevNum -> m ()
-putPage sto page oldRev
+putPage _sto _page _oldRev
= error "FIXME: not implemented"
where
import qualified Codec.Binary.Base64 as B64
+import Codec.Binary.UTF8.String
import Control.Arrow
import Control.Arrow.ArrowIO
import Control.Arrow.ArrowList
import qualified Data.ByteString.Lazy as L
-import Data.Encoding
-import Data.Encoding.UTF8
import qualified Data.Map as M
import Data.Set (Set)
import qualified Data.Set as S
+import Data.Time
+import Data.Time.Clock.POSIX
import Paths_Rakka -- Cabal が用意する。
import Rakka.Page
import Rakka.Utils
-import System.FilePath
-import System.FilePath.Find
import System.Directory
-import System.Time
+import System.FilePath
+import System.FilePath.Find hiding (fileName, modificationTime)
+import System.Posix.Files
import Text.XML.HXT.Arrow.ReadDocument
import Text.XML.HXT.Arrow.XmlArrow
import Text.XML.HXT.Arrow.XmlIOStateArrow
loadDefaultPage :: PageName -> IO (Maybe Page)
-loadDefaultPage pageName
+loadDefaultPage name
-- ./defaultPages が存在するなら、./defaultPages/Foo を探す。無けれ
-- ば Cabal で defaultPages/Foo を探す。
- = do let pagePath = "defaultPages/" ++ encodePageName pageName
+ = do let pagePath = "defaultPages/" ++ encodePageName name
localDirExists <- doesLocalDirExist
if localDirExists then
tryLoad fpath
= do exists <- doesFileExist fpath
if exists then
- return . Just =<< loadPageFile pageName fpath
+ return . Just =<< loadPageFile name fpath
else
return Nothing
, (a_check_namespaces , v_1)
, (a_remove_whitespace, v_1)
] -< fpath
- lastMod <- arrIO (\ x -> getModificationTime x >>= toCalendarTime) -< fpath
+ lastMod <- arrIO (\ x -> getFileStatus x
+ >>=
+ return . posixSecondsToUTCTime . fromRational . toRational . modificationTime)
+ -< fpath
parsePage -< (name, lastMod, tree)
-parsePage :: (ArrowXml a, ArrowChoice a) => a (PageName, CalendarTime, XmlTree) Page
+parsePage :: (ArrowXml a, ArrowChoice a) => a (PageName, UTCTime, XmlTree) Page
parsePage
= proc (name, lastMod, tree)
-> do redirect <- maybeA (getXPathTreesInDoc "/page/@redirect/text()" >>> getText) -< tree
})
-parseEntity :: (ArrowXml a, ArrowChoice a) => a (PageName, CalendarTime, XmlTree) Page
+parseEntity :: (ArrowXml a, ArrowChoice a) => a (PageName, UTCTime, XmlTree) Page
parseEntity
= proc (name, lastMod, tree)
-> do mimeType <- (getXPathTreesInDoc "/page/@type/text()" >>> getText
let (isBinary, content)
= case (textData, binaryData) of
- (Just text, _ ) -> (False, encodeLazy UTF8 text )
- (_ , Just binary) -> (True , L.pack $ B64.decode binary)
+ (Just text, Nothing ) -> (False, L.pack $ encode text )
+ (Nothing , Just binary) -> (True , L.pack $ B64.decode binary)
+ _ -> error "one of textData or binaryData is required"
returnA -< Entity {
pageName = name
import Subversion.Repository
import Text.HyperEstraier hiding (WriteLock)
+
+logger :: String
logger = "Rakka.Storage"
getPage' :: Repository -> PageName -> Maybe RevNum -> IO (Maybe Page)
-getPage' repos name rev
+getPage' _repos name _rev
= loadDefaultPage name -- FIXME
findAllPages :: Repository -> RevNum -> IO (Set PageName)
findAllPages _ 0 = findAllDefaultPages
-findAllPages repos rev
+findAllPages _repos _rev
= findAllDefaultPages -- FIXME
findChangedPages :: Repository -> RevNum -> RevNum -> IO (Set PageName)
findChangedPages repos 0 newRev = findAllPages repos newRev
-findChangedPages repos oldRev newRev
+findChangedPages _repos _oldRev _newRev
= fail "FIXME: not impl"
)
where
+import Codec.Binary.UTF8.String
import Control.Arrow.ArrowIO
import Control.Concurrent.STM
import Control.Monad
import Control.Monad.Trans
import qualified Data.ByteString.Char8 as C8
+import qualified Data.ByteString.Lazy as L
import Data.Dynamic
-import Data.Encoding
-import Data.Encoding.UTF8
import Data.Map (Map)
import qualified Data.Map as M
import Data.Maybe
import Network
import qualified Network.HTTP.Lucu.Config as LC
import Network.HTTP.Lucu.Utils
-import Network.URI
+import Network.URI hiding (path)
import Rakka.Page
import Rakka.Utils
import Subversion.FileSystem
import System.FilePath.Posix
import System.Log.Logger
+
+logger :: String
logger = "Rakka.SystemConfig"
case exists of
True
-> do str <- getFileContentsLBS path
- return $ Just $ chomp $ decodeLazy UTF8 str
+ return $ Just $ chomp $ decode $ L.unpack str
False
-> return Nothing
= let conf = scLucuConf sc
host = C8.unpack $ LC.cnfServerHost conf
port = case LC.cnfServerPort conf of
- PortNumber num -> fromIntegral num
-
+ PortNumber num -> fromIntegral num :: Int
+ _ -> undefined
defaultURI
= "http://" ++ host ++ -- FIXME: consider IPv6 address
(if port == 80
import Control.Arrow
import Control.Arrow.ArrowList
-import System.Time
+import Data.Time
import Text.Printf
_ -> returnA -< str
-formatW3CDateTime :: CalendarTime -> String
-formatW3CDateTime time
- = formatDateTime time ++ formatTimeZone time
+formatW3CDateTime :: ZonedTime -> String
+formatW3CDateTime zonedTime
+ = formatLocalTime (zonedTimeToLocalTime zonedTime)
+ ++
+ formatTimeZone (zonedTimeZone zonedTime)
where
- formatDateTime :: CalendarTime -> String
- formatDateTime time
- = printf "%04d-%02d-%02dT%02d:%02d:%02d"
- (ctYear time)
- (fromEnum (ctMonth time) + 1)
- (ctDay time)
- (ctHour time)
- (ctMin time)
- (ctSec time)
+ formatLocalTime :: LocalTime -> String
+ formatLocalTime localTime
+ = let (year, month, day) = toGregorian (localDay localTime)
+ timeOfDay = localTimeOfDay localTime
+ (secInt, secFrac) = properFraction (todSec timeOfDay)
+ in
+ (printf "%04d-%02d-%02dT%02d:%02d:%02d"
+ year
+ month
+ day
+ (todHour timeOfDay)
+ (todMin timeOfDay)
+ (secInt :: Int))
+ ++
+ (if secFrac == 0
+ then ""
+ else tail (show secFrac))
- formatTimeZone :: CalendarTime -> String
- formatTimeZone time
- = case ctTZ time
- of offset | offset < 0 -> '-':(showTZ $ negate offset)
- | offset == 0 -> "Z"
- | otherwise -> '+':(showTZ offset)
+ formatTimeZone :: TimeZone -> String
+ formatTimeZone tz
+ = case timeZoneMinutes tz of
+ offset | offset < 0 -> '-':(showTZ $ negate offset)
+ | offset == 0 -> "Z"
+ | otherwise -> '+':(showTZ offset)
showTZ :: Int -> String
showTZ offset
- = let hour = offset `div` 3600
- min = (offset - hour * 3600) `div` 60
+ = let hour = offset `div` 60
+ minute = offset - hour * 60
in
- show2 hour ++ ":" ++ show2 min
+ show2 hour ++ ":" ++ show2 minute
show2 :: Int -> String
show2 n | n < 10 = '0':(show n)
where
import qualified Codec.Binary.Base64 as B64
+import Codec.Binary.UTF8.String
import Control.Arrow
import Control.Arrow.ArrowIO
import Control.Arrow.ArrowList
import qualified Data.ByteString.Lazy as L
-import Data.Encoding
-import Data.Encoding.UTF8
import Data.Map (Map)
import qualified Data.Map as M
import Data.Maybe
+import Data.Time
import Network.HTTP.Lucu
import Network.URI
import Rakka.Page
import Rakka.Wiki.Interpreter
import Text.HyperEstraier hiding (getText)
import Text.ParserCombinators.Parsec
-import Text.XML.HXT.Arrow.XmlArrow
+import Text.XML.HXT.Arrow.XmlArrow hiding (err)
import Text.XML.HXT.Arrow.XmlNodeSet
import Text.XML.HXT.DOM.TypeDefs
</binaryData>
</page>
-}
-xmlizePage :: (ArrowXml a, ArrowChoice a) => a Page XmlTree
+xmlizePage :: (ArrowXml a, ArrowChoice a, ArrowIO a) => a Page XmlTree
xmlizePage
= proc page
- -> (eelem "/"
- += ( eelem "page"
- += sattr "name" (pageName page)
- += sattr "type" (show $ pageType page)
- += ( case pageLanguage page of
- Just x -> sattr "lang" x
- Nothing -> none
- )
- += ( case pageFileName page of
- Just x -> sattr "fileName" x
- Nothing -> none
- )
- += ( case pageType page of
- MIMEType "text" "css" _
- -> sattr "isTheme" (yesOrNo $ pageIsTheme page)
- MIMEType "text" "x-rakka" _
- -> sattr "isFeed" (yesOrNo $ pageIsFeed page)
- _
- -> none
- )
- += sattr "isLocked" (yesOrNo $ pageIsLocked page)
- += sattr "isBoring" (yesOrNo $ pageIsBoring page)
- += sattr "isBinary" (yesOrNo $ pageIsBinary page)
- += sattr "revision" (show $ pageRevision page)
- += sattr "lastModified" (formatW3CDateTime $ pageLastMod page)
- += ( case pageSummary page of
- Just s -> eelem "summary" += txt s
- Nothing -> none
- )
- += ( if M.null (pageOtherLang page) then
- none
- else
- selem "otherLang"
- [ eelem "link"
- += sattr "lang" lang
- += sattr "page" page
- | (lang, page) <- M.toList (pageOtherLang page) ]
- )
- += ( if pageIsBinary page then
- ( eelem "binaryData"
- += txt (B64.encode $ L.unpack $ pageContent page)
- )
- else
- ( eelem "textData"
- += txt (decodeLazy UTF8 $ pageContent page)
- )
- )
- )
- ) -<< ()
+ -> do lastMod <- arrIO (utcToLocalZonedTime . pageLastMod) -< page
+ ( eelem "/"
+ += ( eelem "page"
+ += sattr "name" (pageName page)
+ += sattr "type" (show $ pageType page)
+ += ( case pageLanguage page of
+ Just x -> sattr "lang" x
+ Nothing -> none
+ )
+ += ( case pageFileName page of
+ Just x -> sattr "fileName" x
+ Nothing -> none
+ )
+ += ( case pageType page of
+ MIMEType "text" "css" _
+ -> sattr "isTheme" (yesOrNo $ pageIsTheme page)
+ MIMEType "text" "x-rakka" _
+ -> sattr "isFeed" (yesOrNo $ pageIsFeed page)
+ _
+ -> none
+ )
+ += sattr "isLocked" (yesOrNo $ pageIsLocked page)
+ += sattr "isBoring" (yesOrNo $ pageIsBoring page)
+ += sattr "isBinary" (yesOrNo $ pageIsBinary page)
+ += sattr "revision" (show $ pageRevision page)
+ += sattr "lastModified" (formatW3CDateTime lastMod)
+ += ( case pageSummary page of
+ Just s -> eelem "summary" += txt s
+ Nothing -> none
+ )
+ += ( if M.null (pageOtherLang page) then
+ none
+ else
+ selem "otherLang"
+ [ eelem "link"
+ += sattr "lang" lang
+ += sattr "page" name
+ | (lang, name) <- M.toList (pageOtherLang page) ]
+ )
+ += ( if pageIsBinary page then
+ ( eelem "binaryData"
+ += txt (B64.encode $ L.unpack $ pageContent page)
+ )
+ else
+ ( eelem "textData"
+ += txt (decode $ L.unpack $ pageContent page)
+ )
+ )
+ )) -<< ()
wikifyPage :: (ArrowXml a, ArrowChoice a) => InterpTable -> a XmlTree WikiPage
MIMEType "text" "x-rakka" _
-- wikify して興味のある部分を addText する。
-> do arrIO2 (flip setAttribute "rakka:isFeed") -< (doc, pIsFeed)
- wikiPage <- wikifyPage interpTable -< tree
- arrIO2 (mapM_ . addBlockText) -< (doc, wikiPage)
+ wiki <- wikifyPage interpTable -< tree
+ arrIO2 (mapM_ . addBlockText) -< (doc, wiki)
MIMEType _ _ _
-> returnA -< ()
case alt of
Just text -> addHiddenText doc text
Nothing -> return ()
- addInlineText doc (Anchor attrs inlines) = mapM_ (addInlineText doc) inlines
+ addInlineText doc (Anchor _ inlines) = mapM_ (addInlineText doc) inlines
addInlineText _ (Input _) = return ()
addInlineText _ EmptyInline = return ()
addInlineText doc (InlineCmd icmd) = addInlineCmdText doc icmd
import Data.Char
import Data.List
import Data.Maybe
-import Network.URI
+import Network.URI hiding (fragment)
import Rakka.Page
import Rakka.Wiki
import Text.XML.HXT.Arrow.XmlArrow
formatElement :: (ArrowXml a, ArrowChoice a) => a (URI, Element) XmlTree
formatElement
- = proc (baseURI, elem)
- -> case elem of
+ = proc (baseURI, e)
+ -> case e of
Block b -> formatBlock -< (baseURI, b)
Inline i -> formatInline -< (baseURI, i)
EmptyBlock
-> none -< ()
+
+ _ -> arr (error . ("formatBlock: unsupported BlockElement: " ++) . show) -< block
where
formatElem :: (ArrowXml a, ArrowChoice a) =>
String
EmptyInline
-> none -< ()
+
+ _ -> arr (error . ("formatInline: unsupported InlineElement: " ++) . show) -< i
where
formatElem :: (ArrowXml a, ArrowChoice a) =>
String
(Just x, Just y) -> mkPageFragmentURI baseURI x y
(Just x, Nothing) -> mkPageURI baseURI x
(Nothing, Just y) -> mkFragmentURI y
+ _ -> undefined
href = uriToString id uri ""
dLabel = fromMaybe "" page ++ fromMaybe "" (fmap ('#':) fragment)
label = fromMaybe dLabel text
formatImage :: (ArrowXml a) => a (URI, InlineElement) XmlTree
formatImage = proc (baseURI, Image src alt)
-> let uri = case src of
- Left uri -> uri
+ Left u -> u
Right name -> mkObjectURI baseURI name
href = uriToString id uri ""
in
in
case linkTable of
[] -> return EmptyBlock
- xs -> do Languages langTable <- getSysConf (ctxSysConf ctx)
+ _ -> do Languages langTable <- getSysConf (ctxSysConf ctx)
let merged = mergeTables langTable linkTable
return $ mkLangList merged
}
-> [(LanguageTag, PageName)]
-> [(LanguageName, PageName)]
mergeTables _ [] = []
- mergeTables m (x:xs) = let (langTag, pageName) = x
- langName = fromMaybe langTag (M.lookup langTag m)
+ mergeTables m (x:xs) = let (langTag, name) = x
+ langName = fromMaybe langTag (M.lookup langTag m)
in
- (langName, pageName) : mergeTables m xs
+ (langName, name) : mergeTables m xs
mkLangList :: [(LanguageName, PageName)] -> BlockElement
mkLangList xs = List Bullet (map mkLangLink xs)
mkLangLink :: (LanguageName, PageName) -> ListItem
- mkLangLink (langName, pageName)
- = [Inline (PageLink (Just pageName) Nothing (Just langName))]
+ mkLangLink (langName, name)
+ = [Inline (PageLink (Just name) Nothing (Just langName))]
-- <input type="button"
= \ ctx (InlineCommand _ args _) ->
do BaseURI baseURI <- getSysConf (ctxSysConf ctx)
- let pageName = fromMaybe (ctxPageName ctx) (lookup "page" args)
- label = fromMaybe "Edit this page" (lookup "label" args)
- uri = uriToString id baseURI ""
- attrs = [ ("type" , "button")
- , ("value" , label)
- , ("onclick", "Rakka.editPage(\"" ++ uri ++ "\", \"" ++ pageName ++ "\")")
- , ("class" , "editButton")
- ]
+ let name = fromMaybe (ctxPageName ctx) (lookup "page" args)
+ label = fromMaybe "Edit this page" (lookup "label" args)
+ uri = uriToString id baseURI ""
+ attrs = [ ("type" , "button")
+ , ("value" , label)
+ , ("onclick", "Rakka.editPage(\"" ++ uri ++ "\", \"" ++ name ++ "\")")
+ , ("class" , "editButton")
+ ]
return (Input attrs)
}
= InlineCommandInterpreter {
iciName = "img"
, iciInterpret
- = \ ctx (InlineCommand _ attrs inside) ->
+ = \ ctx (InlineCommand _ attrs _) ->
do BaseURI baseURI <- getSysConf (ctxSysConf ctx)
- let pageName = case lookup "src" attrs of
+ let name = case lookup "src" attrs of
Just x -> x
Nothing -> error "\"src\" attribute is missing"
- hrefAttr = ("href", uriToString id (mkPageURI baseURI pageName) "")
+ hrefAttr = ("href", uriToString id (mkPageURI baseURI name) "")
alt = lookup "alt" attrs
classAttr = case lookup "float" attrs of
Nothing -> ("class", "inlineImage")
Just others -> error ("unknown \"float\" attribute: " ++ others)
anchorAttrs = [hrefAttr, classAttr]
- return (Anchor anchorAttrs [Image (Right pageName) alt])
+ return (Anchor anchorAttrs [Image (Right name) alt])
}
= \ ctx (BlockCommand _ attrs inside) ->
do BaseURI baseURI <- getSysConf (ctxSysConf ctx)
- let pageName = case lookup "src" attrs of
+ let name = case lookup "src" attrs of
Just x -> x
Nothing -> error "\"src\" attribute is missing"
- hrefAttr = ("href", uriToString id (mkPageURI baseURI pageName) "")
+ hrefAttr = ("href", uriToString id (mkPageURI baseURI name) "")
classAttr = case lookup "float" attrs of
Nothing -> ("class", "imageFrame")
Just "left" -> ("class", "imageFrame leftFloat")
return (Div [classAttr]
[ Block (Div [("class", "imageData")]
[ Inline (Anchor [hrefAttr]
- [ Image (Right pageName) Nothing ]) ])
+ [ Image (Right name) Nothing ]) ])
, Block (Div [("class", "imageCaption")]
[ Block x | x <- inside ])
]
lastItem' = case lastItem of
[] -> [Block nested]
i:[] -> i ++ [Block nested]
+ _ -> undefined
soFar' = soFar { listItems = nonLastItems ++ [lastItem'] }
in
mkOutline' soFar' level ys
+ _ -> undefined
\ No newline at end of file
where
import Data.Maybe
+import Data.Time
import Network.HTTP.Lucu.RFC1123DateTime
import Rakka.Page
import Rakka.Storage
-> getPage sto name (Just rev) >>= return . fromJust
) result
- return $ mkPageList pages
+ mkPageList pages
}
where
- mkPageList :: [Page] -> BlockElement
+ mkPageList :: [Page] -> IO BlockElement
mkPageList pages
- = Div [("class", "recentUpdates")]
- [ Block (List Bullet (map mkListItem pages)) ]
+ = do items <- mapM mkListItem pages
+ return (Div [("class", "recentUpdates")]
+ [ Block (List Bullet items) ])
- mkListItem :: Page -> ListItem
+ mkListItem :: Page -> IO ListItem
mkListItem page
- = [ Inline ( PageLink {
- linkPage = Just (pageName page)
- , linkFragment = Nothing
- , linkText = Nothing
- }
- )
- , Block ( Div [("class", "date")]
- [Inline (Text (formatRFC1123DateTime (pageLastMod page)))]
- )
- ]
- ++
- case pageSummary page of
- Just s -> [ Block (Paragraph [Text s]) ]
- Nothing -> []
+ = do lastMod <- utcToLocalZonedTime (pageLastMod page)
+ return ( [ Inline ( PageLink {
+ linkPage = Just (pageName page)
+ , linkFragment = Nothing
+ , linkText = Nothing
+ }
+ )
+ , Block ( Div [("class", "date")]
+ [Inline (Text (formatRFC1123DateTime lastMod))]
+ )
+ ]
+ ++
+ case pageSummary page of
+ Just s -> [ Block (Paragraph [Text s]) ]
+ Nothing -> []
+ )
where
import Data.Maybe
-import Network.URI
+import Network.URI hiding (fragment)
import Rakka.Wiki
-import Text.ParserCombinators.Parsec
+import Text.ParserCombinators.Parsec hiding (label)
type CommandTypeOf = String -> Maybe CommandType
toType :: Char -> ListType
toType '*' = Bullet
toType '#' = Numbered
+ toType _ = undefined
definitionList :: CommandTypeOf -> Parser BlockElement
return []
-blockCommand :: Parser BlockElement
-blockCommand = pzero -- not implemented
-
-
paragraph :: CommandTypeOf -> Parser BlockElement
paragraph cmdTypeOf = paragraph' >>= return . Paragraph
where
objLink :: Parser InlineElement
objLink = do try (string "[[[")
- page <- many1 (noneOf "|]")
- text <- option Nothing
- (char '|' >> many1 (satisfy (/= ']')) >>= return . Just)
+ page <- many1 (noneOf "|]")
+ label <- option Nothing
+ (char '|' >> many1 (satisfy (/= ']')) >>= return . Just)
string "]]]"
- return $ ObjectLink page text
+ return $ ObjectLink page label
<?>
"object link"
(many1 (noneOf "#|]") >>= return . Just)
fragment <- option Nothing
(char '#' >> many1 (noneOf "|]") >>= return . Just)
- text <- option Nothing
+ label <- option Nothing
(char '|' >> many1 (satisfy (/= ']')) >>= return . Just)
case (page, fragment) of
(_, _) -> return ()
string "]]"
- return $ PageLink page fragment text
+ return $ PageLink page fragment label
<?>
"page link"
extLink = do char '['
uriStr <- many1 (noneOf " \t]")
skipMany (oneOf " \t")
- text <- option Nothing
- (many1 (noneOf "]") >>= return . Just)
+ label <- option Nothing
+ (many1 (noneOf "]") >>= return . Just)
case parseURI uriStr of
- Just uri -> char ']' >> return (ExternalLink uri text)
+ Just uri -> char ']' >> return (ExternalLink uri label)
Nothing -> pzero <?> "absolute URI"
<?>
"external link"
main = defaultMainWithHooks (defaultUserHooks { runTests = runTestUnit })
where
runTestUnit _ _ _ _
- = system "./dist/build/RakkaUnitTest/RakkaUnitTest"
+ = system "./dist/build/RakkaUnitTest/RakkaUnitTest" >> return ()
AC_SUBST([RAKKA_LOCALSTATEDIR])
-# Since the Cabal executes ./configure with no arguments, the only way
-# we can receive options from user is to see environment variables.
-AC_ARG_VAR([BUILD_TEST_SUITE], [build and install the test suite. (yes / no) (default: no)])
-if test "$BUILD_TEST_SUITE" = ""; then
- BUILD_TEST_SUITE=False
-elif test "$BUILD_TEST_SUITE" = "yes"; then
- BUILD_TEST_SUITE=True
-elif test "$BUILD_TEST_SUITE" = "no"; then
- BUILD_TEST_SUITE=False
-else
- AC_MSG_ERROR([BUILD_TEST_SUITE must be either yes or no.])
-fi
-
-
AC_CONFIG_FILES([
Rakka.buildinfo
])
import Test.HUnit
import qualified WikiParserTest
-main = runTestTT (test testData)
+main :: IO ()
+main = runTestTT (test testData) >> return ()
testData :: [Test]
testData = WikiParserTest.testData
\ No newline at end of file
]
]))
- , (parseWiki "<![CDATA[foo [[bar]] baz]]>"
+ , (parseWiki "<!nowiki[foo [[bar]] baz]>"
~?=
(Right [ Paragraph [ Text "foo [[bar]] baz" ] ]))
- , (parseWiki "<![PDATA[foo [[bar]] baz]]>"
+ , (parseWiki "<!verbatim[foo [[bar]] baz]>"
~?=
(Right [ Preformatted [ Text "foo [[bar]] baz" ] ]))
- , (parseWiki "<![PDATA[\nfoo [[bar]] baz\n]]>"
+ , (parseWiki "<!verbatim[\nfoo [[bar]] baz\n]>"
~?=
(Right [ Preformatted [ Text "foo [[bar]] baz" ] ]))
projects / Rakka.git / commitdiff