From 7a4f13a3d483c950743e1ced001ade4406d239d3 Mon Sep 17 00:00:00 2001 From: pho Date: Tue, 6 Nov 2007 14:24:01 +0900 Subject: [PATCH] Exodus to GHC 6.8.1 darcs-hash:20071106052401-62b54-add9c5c5d102624e06280b45b93a7a67d562d8bd.gz --- Main.hs | 2 + Makefile | 12 +-- Rakka.buildinfo.in | 8 +- Rakka.cabal | 131 ++++++++++++++--------------- Rakka/Environment.hs | 1 + Rakka/Page.hs | 22 +++-- Rakka/Resource.hs | 3 +- Rakka/Resource/Object.hs | 16 ++-- Rakka/Resource/PageEntity.hs | 29 +++---- Rakka/Storage.hs | 4 +- Rakka/Storage/DefaultPage.hs | 31 ++++--- Rakka/Storage/Impl.hs | 8 +- Rakka/SystemConfig.hs | 14 +-- Rakka/Utils.hs | 54 +++++++----- Rakka/Wiki/Engine.hs | 112 ++++++++++++------------ Rakka/Wiki/Formatter.hs | 13 ++- Rakka/Wiki/Interpreter/Base.hs | 28 +++--- Rakka/Wiki/Interpreter/Image.hs | 14 +-- Rakka/Wiki/Interpreter/Outline.hs | 2 + Rakka/Wiki/Interpreter/PageList.hs | 42 ++++----- Rakka/Wiki/Parser.hs | 27 +++--- Setup.hs | 2 +- configure.ac | 14 --- tests/RakkaUnitTest.hs | 3 +- tests/WikiParserTest.hs | 6 +- 25 files changed, 300 insertions(+), 298 deletions(-) diff --git a/Main.hs b/Main.hs index 6621f58..5db2fcc 100644 --- a/Main.hs +++ b/Main.hs @@ -22,6 +22,8 @@ import System.Posix.Files import System.Posix.Types import System.Posix.User + +logger :: String logger = "Main" diff --git a/Makefile b/Makefile index 99956d4..05b96a1 100644 --- a/Makefile +++ b/Makefile @@ -2,7 +2,7 @@ CABAL_FILE = Rakka.cabal 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 @@ -12,8 +12,9 @@ run: 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 @@ -22,7 +23,8 @@ Setup: Setup.hs $(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 @@ -34,4 +36,4 @@ test: 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 diff --git a/Rakka.buildinfo.in b/Rakka.buildinfo.in index 2949f94..04ab233 100644 --- a/Rakka.buildinfo.in +++ b/Rakka.buildinfo.in @@ -1,10 +1,4 @@ -- -*- haskell-cabal -*- -Executable: - rakka +Executable: rakka GHC-Options: -DLOCALSTATEDIR="@RAKKA_LOCALSTATEDIR@" - -Executable: - RakkaUnitTest -Buildable: - @BUILD_TEST_SUITE@ diff --git a/Rakka.cabal b/Rakka.cabal index 82bb773..2a23227 100644 --- a/Rakka.cabal +++ b/Rakka.cabal @@ -1,29 +1,17 @@ -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 -Maintainer: - PHO -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 +Maintainer: PHO +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 @@ -34,6 +22,7 @@ Data-Files: defaultPages/SideBar/Right defaultPages/StyleSheet/Default schemas/rakka-page-1.0.rng + Extra-Source-Files: Rakka.buildinfo.in configure @@ -45,48 +34,56 @@ Extra-Source-Files: 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 diff --git a/Rakka/Environment.hs b/Rakka/Environment.hs index d40294a..480fcf2 100644 --- a/Rakka/Environment.hs +++ b/Rakka/Environment.hs @@ -29,6 +29,7 @@ import Text.HyperEstraier import Text.XML.HXT.Arrow.XmlIOStateArrow +logger :: String logger = "Rakka.Environment" diff --git a/Rakka/Page.hs b/Rakka/Page.hs index 9d84cf2..453ed84 100644 --- a/Rakka/Page.hs +++ b/Rakka/Page.hs @@ -19,18 +19,16 @@ module Rakka.Page ) 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 @@ -44,7 +42,7 @@ data Page redirName :: !PageName , redirDest :: !PageName , redirRevision :: !(Maybe RevNum) - , redirLastMod :: !CalendarTime + , redirLastMod :: !UTCTime } | Entity { pageName :: !PageName @@ -57,16 +55,16 @@ data Page , 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) @@ -82,11 +80,11 @@ isSafeChar 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 diff --git a/Rakka/Resource.hs b/Rakka/Resource.hs index ec14373..a69a224 100644 --- a/Rakka/Resource.hs +++ b/Rakka/Resource.hs @@ -10,7 +10,7 @@ import Control.Monad 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 @@ -73,6 +73,7 @@ outputXmlPage tree toXHTML let formatter = case mType of MIMEType "application" "xhtml+xml" _ -> toXHTML MIMEType "text" "xml" _ -> this + _ -> undefined [resultStr] <- liftIO $ runX ( setErrorMsgHandler False fail >>> constA tree diff --git a/Rakka/Resource/Object.hs b/Rakka/Resource/Object.hs index a18a268..cd2c364 100644 --- a/Rakka/Resource/Object.hs +++ b/Rakka/Resource/Object.hs @@ -1,3 +1,4 @@ +-- -*- Coding: utf-8 -*- module Rakka.Resource.Object ( resObject ) @@ -11,7 +12,6 @@ import Rakka.Environment import Rakka.Page import Rakka.Storage import Rakka.SystemConfig -import System.Time resObject :: Environment -> ResourceDef @@ -41,7 +41,7 @@ handleGet env name -> handleRedirect env redir Just entity@(Entity _ _ _ _ _ _ _ _ _ _ _ _ _ _) - -> handleGetEntity env entity + -> handleGetEntity entity {- @@ -60,13 +60,11 @@ handleRedirect env redir ... -} -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") diff --git a/Rakka/Resource/PageEntity.hs b/Rakka/Resource/PageEntity.hs index 32a4a61..19e9768 100644 --- a/Rakka/Resource/PageEntity.hs +++ b/Rakka/Resource/PageEntity.hs @@ -11,7 +11,7 @@ import Data.Char 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 @@ -19,7 +19,6 @@ import Rakka.Storage 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 @@ -74,17 +73,15 @@ handleGetEntity :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a Pa 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) @@ -96,14 +93,14 @@ 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 "/" @@ -203,14 +200,14 @@ notFoundToXHTML env 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" @@ -272,7 +269,7 @@ notFoundToXHTML env handlePut :: Environment -> PageName -> Resource () -handlePut env name +handlePut _env _name = do xml <- input defaultLimit setContentType $ read "text/xml" output xml diff --git a/Rakka/Storage.hs b/Rakka/Storage.hs index 3a883d3..945bfd3 100644 --- a/Rakka/Storage.hs +++ b/Rakka/Storage.hs @@ -28,8 +28,6 @@ import System.IO import Subversion.Repository import Text.HyperEstraier hiding (WriteLock) -logger = "Rakka.Storage" - mkStorage :: FilePath -> Repository -> (Page -> IO Document) -> IO Storage mkStorage lsdir repos mkDraft @@ -47,7 +45,7 @@ getPage = ((liftIO .) .) . getPage' . stoRepository putPage :: MonadIO m => Storage -> Page -> RevNum -> m () -putPage sto page oldRev +putPage _sto _page _oldRev = error "FIXME: not implemented" diff --git a/Rakka/Storage/DefaultPage.hs b/Rakka/Storage/DefaultPage.hs index 3e4e421..46fda3a 100644 --- a/Rakka/Storage/DefaultPage.hs +++ b/Rakka/Storage/DefaultPage.hs @@ -5,22 +5,23 @@ module Rakka.Storage.DefaultPage 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 @@ -52,10 +53,10 @@ findAllDefaultPages 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 @@ -67,7 +68,7 @@ loadDefaultPage pageName tryLoad fpath = do exists <- doesFileExist fpath if exists then - return . Just =<< loadPageFile pageName fpath + return . Just =<< loadPageFile name fpath else return Nothing @@ -90,11 +91,14 @@ loadPageFileA , (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 @@ -108,7 +112,7 @@ parsePage }) -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 @@ -141,8 +145,9 @@ parseEntity 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 diff --git a/Rakka/Storage/Impl.hs b/Rakka/Storage/Impl.hs index 5db3f92..c324692 100644 --- a/Rakka/Storage/Impl.hs +++ b/Rakka/Storage/Impl.hs @@ -27,23 +27,25 @@ import Subversion.FileSystem 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" diff --git a/Rakka/SystemConfig.hs b/Rakka/SystemConfig.hs index 6760386..10b39b3 100644 --- a/Rakka/SystemConfig.hs +++ b/Rakka/SystemConfig.hs @@ -15,14 +15,14 @@ module Rakka.SystemConfig ) 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 @@ -30,7 +30,7 @@ import GHC.Conc (unsafeIOToSTM) 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 @@ -40,6 +40,8 @@ import Subversion.Repository import System.FilePath.Posix import System.Log.Logger + +logger :: String logger = "Rakka.SystemConfig" @@ -92,7 +94,7 @@ getSysConf' sc case exists of True -> do str <- getFileContentsLBS path - return $ Just $ chomp $ decodeLazy UTF8 str + return $ Just $ chomp $ decode $ L.unpack str False -> return Nothing @@ -160,8 +162,8 @@ instance SysConfValue BaseURI where = 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 diff --git a/Rakka/Utils.hs b/Rakka/Utils.hs index 9f2873c..f58a0b8 100644 --- a/Rakka/Utils.hs +++ b/Rakka/Utils.hs @@ -10,7 +10,7 @@ module Rakka.Utils import Control.Arrow import Control.Arrow.ArrowList -import System.Time +import Data.Time import Text.Printf @@ -42,33 +42,43 @@ deleteIfEmpty _ -> 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) diff --git a/Rakka/Wiki/Engine.hs b/Rakka/Wiki/Engine.hs index a4b70d7..54d0ff7 100644 --- a/Rakka/Wiki/Engine.hs +++ b/Rakka/Wiki/Engine.hs @@ -8,15 +8,15 @@ module Rakka.Wiki.Engine 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 @@ -29,7 +29,7 @@ import Rakka.Wiki.Formatter 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 @@ -66,58 +66,58 @@ type InterpTable = Map String Interpreter -} -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 @@ -328,8 +328,8 @@ makeDraft interpTable 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 -< () @@ -372,7 +372,7 @@ makeDraft interpTable 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 diff --git a/Rakka/Wiki/Formatter.hs b/Rakka/Wiki/Formatter.hs index 4b483db..0dfe02e 100644 --- a/Rakka/Wiki/Formatter.hs +++ b/Rakka/Wiki/Formatter.hs @@ -8,7 +8,7 @@ import Control.Arrow.ArrowList 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 @@ -25,8 +25,8 @@ formatWikiBlocks 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) @@ -58,6 +58,8 @@ formatBlock EmptyBlock -> none -< () + + _ -> arr (error . ("formatBlock: unsupported BlockElement: " ++) . show) -< block where formatElem :: (ArrowXml a, ArrowChoice a) => String @@ -192,6 +194,8 @@ formatInline EmptyInline -> none -< () + + _ -> arr (error . ("formatInline: unsupported InlineElement: " ++) . show) -< i where formatElem :: (ArrowXml a, ArrowChoice a) => String @@ -232,6 +236,7 @@ formatPageLink (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 @@ -242,7 +247,7 @@ formatPageLink 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 diff --git a/Rakka/Wiki/Interpreter/Base.hs b/Rakka/Wiki/Interpreter/Base.hs index 9a02ae2..70951e6 100644 --- a/Rakka/Wiki/Interpreter/Base.hs +++ b/Rakka/Wiki/Interpreter/Base.hs @@ -78,7 +78,7 @@ otherLangsInterp 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 } @@ -87,17 +87,17 @@ otherLangsInterp -> [(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))] -- 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) } diff --git a/Rakka/Wiki/Interpreter/Image.hs b/Rakka/Wiki/Interpreter/Image.hs index 97ffc8e..9b6ff74 100644 --- a/Rakka/Wiki/Interpreter/Image.hs +++ b/Rakka/Wiki/Interpreter/Image.hs @@ -26,13 +26,13 @@ imageInterp = 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") @@ -41,7 +41,7 @@ imageInterp Just others -> error ("unknown \"float\" attribute: " ++ others) anchorAttrs = [hrefAttr, classAttr] - return (Anchor anchorAttrs [Image (Right pageName) alt]) + return (Anchor anchorAttrs [Image (Right name) alt]) } @@ -63,10 +63,10 @@ imgFrameInterp = \ 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") @@ -76,7 +76,7 @@ imgFrameInterp 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 ]) ] diff --git a/Rakka/Wiki/Interpreter/Outline.hs b/Rakka/Wiki/Interpreter/Outline.hs index ef9c320..f6d798d 100644 --- a/Rakka/Wiki/Interpreter/Outline.hs +++ b/Rakka/Wiki/Interpreter/Outline.hs @@ -82,7 +82,9 @@ mkOutline' soFar level (x:xs) 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 diff --git a/Rakka/Wiki/Interpreter/PageList.hs b/Rakka/Wiki/Interpreter/PageList.hs index 69ff0e7..234ce7d 100644 --- a/Rakka/Wiki/Interpreter/PageList.hs +++ b/Rakka/Wiki/Interpreter/PageList.hs @@ -4,6 +4,7 @@ module Rakka.Wiki.Interpreter.PageList where import Data.Maybe +import Data.Time import Network.HTTP.Lucu.RFC1123DateTime import Rakka.Page import Rakka.Storage @@ -49,27 +50,30 @@ recentUpdatesInterp -> 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 -> [] + ) diff --git a/Rakka/Wiki/Parser.hs b/Rakka/Wiki/Parser.hs index 4d936f9..912237c 100644 --- a/Rakka/Wiki/Parser.hs +++ b/Rakka/Wiki/Parser.hs @@ -5,9 +5,9 @@ module Rakka.Wiki.Parser 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 @@ -104,6 +104,7 @@ listElement cmdTypeOf = listElement' [] toType :: Char -> ListType toType '*' = Bullet toType '#' = Numbered + toType _ = undefined definitionList :: CommandTypeOf -> Parser BlockElement @@ -186,10 +187,6 @@ leadingSpaced cmdTypeOf = (char ' ' >> leadingSpaced' >>= return . Preformatted) return [] -blockCommand :: Parser BlockElement -blockCommand = pzero -- not implemented - - paragraph :: CommandTypeOf -> Parser BlockElement paragraph cmdTypeOf = paragraph' >>= return . Paragraph where @@ -346,11 +343,11 @@ apostrophes cmdTypeOf = foldr (<|>) pzero (map try [apos1, apos2, apos3, apos4, 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" @@ -361,7 +358,7 @@ pageLink = do try (string "[[") (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 @@ -369,7 +366,7 @@ pageLink = do try (string "[[") (_, _) -> return () string "]]" - return $ PageLink page fragment text + return $ PageLink page fragment label "page link" @@ -378,11 +375,11 @@ extLink :: Parser InlineElement 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" diff --git a/Setup.hs b/Setup.hs index 857ea9c..43dff8c 100755 --- a/Setup.hs +++ b/Setup.hs @@ -7,4 +7,4 @@ import System.Exit main = defaultMainWithHooks (defaultUserHooks { runTests = runTestUnit }) where runTestUnit _ _ _ _ - = system "./dist/build/RakkaUnitTest/RakkaUnitTest" + = system "./dist/build/RakkaUnitTest/RakkaUnitTest" >> return () diff --git a/configure.ac b/configure.ac index 39ea418..b578bbc 100644 --- a/configure.ac +++ b/configure.ac @@ -14,20 +14,6 @@ RAKKA_LOCALSTATEDIR=`eval echo "$localstatedir"`/rakka 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 ]) diff --git a/tests/RakkaUnitTest.hs b/tests/RakkaUnitTest.hs index 3099a96..6fc46f5 100644 --- a/tests/RakkaUnitTest.hs +++ b/tests/RakkaUnitTest.hs @@ -1,7 +1,8 @@ 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 diff --git a/tests/WikiParserTest.hs b/tests/WikiParserTest.hs index 56942c6..a7c5c70 100644 --- a/tests/WikiParserTest.hs +++ b/tests/WikiParserTest.hs @@ -270,15 +270,15 @@ testData = [ (parseWiki "" ] ])) - , (parseWiki "" + , (parseWiki "" ~?= (Right [ Paragraph [ Text "foo [[bar]] baz" ] ])) - , (parseWiki "" + , (parseWiki "" ~?= (Right [ Preformatted [ Text "foo [[bar]] baz" ] ])) - , (parseWiki "" + , (parseWiki "" ~?= (Right [ Preformatted [ Text "foo [[bar]] baz" ] ])) -- 2.40.0