From 885faf1cabc3f79c90e1885268e2a9138b1ddefb Mon Sep 17 00:00:00 2001 From: pho Date: Wed, 10 Oct 2007 00:26:09 +0900 Subject: [PATCH] wrote much code... darcs-hash:20071009152609-62b54-4ad6a3ed116793bf48b02b07f16cc282636568fe.gz --- Rakka.cabal | 3 +- Rakka/Environment.hs | 51 +------ Rakka/Page.hs | 59 ++++---- Rakka/Resource.hs | 7 +- Rakka/Resource/Object.hs | 55 ++++++- Rakka/Resource/Page.hs | 8 +- Rakka/Resource/Page/Get.hs | 213 +++++++++++++++++++++------ Rakka/Storage.hs | 11 +- Rakka/Storage/DefaultPage.hs | 30 ++-- Rakka/SystemConfig.hs | 87 +++++++++++ Rakka/Utils.hs | 8 +- defaultPages/{Main_Page => MainPage} | 7 +- defaultPages/StyleSheet/Default | 30 ++++ 13 files changed, 419 insertions(+), 150 deletions(-) create mode 100644 Rakka/SystemConfig.hs rename defaultPages/{Main_Page => MainPage} (65%) create mode 100644 defaultPages/StyleSheet/Default diff --git a/Rakka.cabal b/Rakka.cabal index 9c173bf..07f3e41 100644 --- a/Rakka.cabal +++ b/Rakka.cabal @@ -25,10 +25,11 @@ Extensions: GHC-Options: -fwarn-unused-imports Build-Depends: - base, mtl, network, unix, encoding, base64-string, hxt, HsSVN, Lucu + base, mtl, network, unix, encoding, Crypto, hxt, filepath, HsSVN, Lucu Exposed-Modules: Rakka.Page Rakka.Storage + Rakka.SystemConfig Other-Modules: Rakka.Environment Rakka.Storage.DefaultPage diff --git a/Rakka/Environment.hs b/Rakka/Environment.hs index 881a9e6..015d37d 100644 --- a/Rakka/Environment.hs +++ b/Rakka/Environment.hs @@ -1,28 +1,20 @@ module Rakka.Environment ( Environment(..) , setupEnv - - , getSiteName - , getSiteNameA - - , getBaseURI - , getBaseURIA ) where -import Control.Arrow.ArrowIO -import qualified Data.ByteString.Char8 as C8 -import Data.Maybe import Network import qualified Network.HTTP.Lucu.Config as LC -import Network.URI import Rakka.Storage +import Rakka.SystemConfig data Environment = Environment { - envLocalStateDir :: FilePath - , envLucuConf :: LC.Config - , envStorage :: Storage + envLocalStateDir :: !FilePath + , envLucuConf :: !LC.Config + , envStorage :: !Storage + , envSysConf :: !SystemConfig } @@ -31,38 +23,9 @@ setupEnv lsdir portNum = do let lucuConf = LC.defaultConfig { LC.cnfServerPort = PortNumber portNum } - storage <- mkStorage -- FIXME return $ Environment { envLocalStateDir = lsdir , envLucuConf = lucuConf - , envStorage = storage + , envStorage = mkStorage + , envSysConf = mkSystemConfig lucuConf } - - -getSiteName :: Environment -> IO String -getSiteName env - = return "Rakka" -- FIXME - - -getSiteNameA :: ArrowIO a => Environment -> a b String -getSiteNameA = arrIO0 . getSiteName - - -getBaseURI :: Environment -> IO URI -getBaseURI env - = do let conf = envLucuConf env - host = C8.unpack $ LC.cnfServerHost conf - port = case LC.cnfServerPort conf of - PortNumber num -> fromIntegral num - - defaultURI - = "http://" ++ host ++ - (if port == 80 - then "" - else ':' : show port) ++ "/" - - return $ fromJust $ parseURI defaultURI -- FIXME - - -getBaseURIA :: ArrowIO a => Environment -> a b URI -getBaseURIA = arrIO0 . getBaseURI \ No newline at end of file diff --git a/Rakka/Page.hs b/Rakka/Page.hs index 2e3ea45..c22e520 100644 --- a/Rakka/Page.hs +++ b/Rakka/Page.hs @@ -4,6 +4,7 @@ module Rakka.Page , encodePageName , decodePageName , mkPageURI + , mkObjectURI ) where @@ -14,6 +15,7 @@ import Data.Encoding.UTF8 import Network.HTTP.Lucu import Network.URI import Subversion.Types +import System.FilePath import System.Time @@ -22,34 +24,35 @@ type PageName = String data Page = Redirection { - redirName :: PageName - , redirDest :: PageName - , redirRevision :: Maybe RevNum - , redirLastMod :: CalendarTime + redirName :: !PageName + , redirDest :: !PageName + , redirRevision :: !(Maybe RevNum) + , redirLastMod :: !CalendarTime } | Entity { - pageName :: PageName - , pageType :: MIMEType - , pageIsTheme :: Bool -- text/css 以外では無意味 - , pageIsFeed :: Bool -- text/x-rakka 以外では無意味 - , pageIsLocked :: Bool - , pageIsBoring :: Bool - , pageRevision :: Maybe RevNum - , pageLastMod :: CalendarTime - , pageSummary :: Maybe String - , pageOtherLang :: [(String, PageName)] - , pageContent :: LazyByteString + pageName :: !PageName + , pageType :: !MIMEType + , pageIsTheme :: !Bool -- text/css 以外では無意味 + , pageIsFeed :: !Bool -- text/x-rakka 以外では無意味 + , pageIsLocked :: !Bool + , pageIsBoring :: !Bool + , pageIsBinary :: !Bool + , pageRevision :: !(Maybe RevNum) + , pageLastMod :: !CalendarTime + , pageSummary :: !(Maybe String) + , pageOtherLang :: ![(String, PageName)] + , pageContent :: !LazyByteString } -- UTF-8 に encode してから 0x20 - 0x7E の範圍を除いて URI escape する。 encodePageName :: PageName -> FilePath -encodePageName = escapeURIString shouldEscape . C8.unpack . encode UTF8 +encodePageName = escapeURIString isSafe . C8.unpack . encode UTF8 where - shouldEscape :: Char -> Bool - shouldEscape c - | c >= ' ' && c <= '~' = False - | otherwise = True + isSafe :: Char -> Bool + isSafe c + | c >= ' ' && c <= '~' = True + | otherwise = False -- URI unescape して UTF-8 から decode する。 @@ -59,9 +62,13 @@ decodePageName = decode UTF8 . C8.pack . unEscapeString mkPageURI :: URI -> PageName -> URI mkPageURI baseURI name - | uriPath baseURI == "" = baseURI { uriPath = "/" ++ encoded } - | uriPath baseURI == "/" = baseURI { uriPath = "/" ++ encoded } - | last (uriPath baseURI) == '/' = baseURI { uriPath = uriPath baseURI ++ encoded } - | otherwise = baseURI { uriPath = uriPath baseURI ++ "/" ++ encoded } - where - encoded = encodePageName name + = baseURI { + uriPath = foldl combine "/" [uriPath baseURI, encodePageName name] + } + + +mkObjectURI :: URI -> PageName -> URI +mkObjectURI baseURI name + = baseURI { + uriPath = foldl combine "/" [uriPath baseURI, "object", encodePageName name] + } diff --git a/Rakka/Resource.hs b/Rakka/Resource.hs index c79b215..e1166b4 100644 --- a/Rakka/Resource.hs +++ b/Rakka/Resource.hs @@ -70,10 +70,9 @@ outputXmlPage :: XmlTree -> IOSArrow XmlTree XmlTree -> Resource () outputXmlPage tree toXHTML = do mType <- getEntityType setContentType mType - let formatter = if mType == read "text/xml" then - this - else - toXHTML + let formatter = case mType of + MIMEType "application" "xhtml+xml" _ -> toXHTML + MIMEType "text" "xml" _ -> this [resultStr] <- liftIO $ runX ( setErrorMsgHandler False fail >>> constA tree diff --git a/Rakka/Resource/Object.hs b/Rakka/Resource/Object.hs index 9e30d1e..af0d9b7 100644 --- a/Rakka/Resource/Object.hs +++ b/Rakka/Resource/Object.hs @@ -4,19 +4,68 @@ module Rakka.Resource.Object where import Network.HTTP.Lucu +import Network.HTTP.Lucu.Utils import Rakka.Environment +import Rakka.Page +import Rakka.Storage +import Rakka.SystemConfig +import System.FilePath +import System.Time resObject :: Environment -> ResourceDef resObject env = ResourceDef { resUsesNativeThread = False - , resIsGreedy = False - , resGet = Just $ do setContentType $ read "text/plain" - output "FIXME: not implemented" + , resIsGreedy = True + , resGet = Just $ getPathInfo >>= handleGet env . toPageName , resHead = Nothing , resPost = Nothing , resPut = Nothing , resDelete = Nothing } + where + toPageName :: [String] -> PageName + toPageName = decodePageName . dropExtension . joinWith "/" + + +handleGet :: Environment -> PageName -> Resource () +handleGet env name + = do pageM <- getPage (envStorage env) name + case pageM of + Nothing + -> foundNoEntity Nothing + + Just redir@(Redirection _ _ _ _) + -> handleRedirect env redir + + Just entity@(Entity _ _ _ _ _ _ _ _ _ _ _ _) + -> handleGetEntity env entity + + +{- + HTTP/1.1 302 Found + Location: http://example.org/object/Destination +-} +handleRedirect :: Environment -> Page -> Resource () +handleRedirect env redir + = do BaseURI baseURI <- getSysConf (envSysConf env) (BaseURI undefined) + redirect Found (mkObjectURI baseURI $ redirName redir) + + +{- + HTTP/1.1 200 OK + Content-Type: image/png + + ... +-} +handleGetEntity :: Environment -> Page -> Resource () +handleGetEntity env page + = do let lastMod = toClockTime $ pageLastMod page + + case pageRevision page of + Nothing -> foundTimeStamp lastMod + Just rev -> foundEntity (strongETag $ show rev) lastMod + setContentType (pageType page) + outputLBS (pageContent page) diff --git a/Rakka/Resource/Page.hs b/Rakka/Resource/Page.hs index c72cf88..6d8c7d5 100644 --- a/Rakka/Resource/Page.hs +++ b/Rakka/Resource/Page.hs @@ -9,6 +9,7 @@ import Network.HTTP.Lucu.Utils import Rakka.Environment import Rakka.Page import Rakka.Resource.Page.Get +import System.FilePath fallbackPage :: Environment -> [String] -> IO (Maybe ResourceDef) @@ -26,10 +27,9 @@ fallbackPage env path , resPut = Just $ handlePut env (toPageName path) , resDelete = Just $ handleDelete env (toPageName path) } - - -toPageName :: [String] -> PageName -toPageName = decodePageName . joinWith "/" + where + toPageName :: [String] -> PageName + toPageName = decodePageName . dropExtension . joinWith "/" handlePut :: Environment -> PageName -> Resource () diff --git a/Rakka/Resource/Page/Get.hs b/Rakka/Resource/Page/Get.hs index 322e9db..30da9b9 100644 --- a/Rakka/Resource/Page/Get.hs +++ b/Rakka/Resource/Page/Get.hs @@ -4,35 +4,56 @@ module Rakka.Resource.Page.Get where import Control.Arrow +import Control.Arrow.ArrowIf +import Control.Arrow.ArrowIO import Control.Arrow.ArrowList +import Data.Encoding +import Data.Encoding.UTF8 import Network.HTTP.Lucu import Network.URI import Rakka.Environment import Rakka.Page import Rakka.Resource import Rakka.Storage +import Rakka.SystemConfig import Rakka.Utils +import System.Time import Text.XML.HXT.Arrow.XmlArrow +import Text.XML.HXT.Arrow.XmlNodeSet import Text.XML.HXT.DOM.TypeDefs +handleGet :: Environment -> PageName -> Resource () +handleGet env name + = runIdempotentA $ proc () + -> do pageM <- getPageA (envStorage env) -< name + case pageM of + Nothing + -> returnA -< foundNoEntity Nothing + + Just redir@(Redirection _ _ _ _) + -> handleRedirect env -< redir + + Just entity@(Entity _ _ _ _ _ _ _ _ _ _ _ _) + -> handleGetEntity env -< entity + {- - [リダイレクトの場合] HTTP/1.1 302 Found Location: http://example.org/Destination?from=Source&revision=112 - - +-} +handleRedirect :: (ArrowXml a, ArrowIO a) => Environment -> a Page (Resource ()) +handleRedirect env + = proc redir + -> do BaseURI baseURI <- getSysConfA (envSysConf env) (BaseURI undefined) -< () + returnA -< redirect Found (mkPageURI baseURI $ redirName redir) -- FIXME - [text/* の場合] +{- + [pageIsBinary が False の場合] -- 存在しない場合もある - + -- 存在しない場合もある @@ -55,40 +76,144 @@ import Text.XML.HXT.DOM.TypeDefs - [text/* 以外の場合: content 要素の代はりに object 要素] + [pageIsBinary が True の場合: content 要素の代はりに object 要素] -- data 屬性に URI -} -handleGet :: Environment -> PageName -> Resource () -handleGet env name - = let sto = envStorage env - in - runIdempotentA $ proc () - -> do siteName <- getSiteNameA env -< () - baseURI <- getBaseURIA env -< () - - pageM <- getPageA sto -< name - case pageM of - Nothing - -> returnA -< foundNoEntity Nothing - - Just redir@(Redirection _ _ _ _) - -> do tree <- ( eelem "/" - += ( eelem "page" - += sattr "site" siteName - += sattr "baseURI" (uriToString id baseURI "") - += sattr "name" name - += sattr "redirect" (redirDest redir) - += ( case redirRevision redir of - Nothing -> none - Just rev -> sattr "revision" (show rev) - ) - += sattr "lastModified" (formatW3CDateTime $ redirLastMod redir) - ) - ) -<< () - returnA -< do redirect SeeOther (mkPageURI baseURI name) - outputXmlPage tree redirToXHTML - - -redirToXHTML :: ArrowXml a => a XmlTree XmlTree -redirToXHTML = error "not implemented" \ No newline at end of file +handleGetEntity :: (ArrowXml a, ArrowIO a) => Environment -> a Page (Resource ()) +handleGetEntity env + = let sysConf = envSysConf env + in + proc page + -> do SiteName siteName <- getSysConfA sysConf (SiteName undefined) -< () + BaseURI baseURI <- getSysConfA sysConf (BaseURI undefined) -< () + StyleSheet cssName <- getSysConfA sysConf (StyleSheet undefined) -< () + + tree <- ( eelem "/" + += ( eelem "page" + += sattr "site" siteName + += sattr "baseURI" (uriToString id baseURI "") + += sattr "styleSheet" cssName + += sattr "name" (pageName page) + += sattr "type" (show $ pageType page) + += ( case pageType page of + MIMEType "text" "css" _ + -> sattr "isTheme" (yesOrNo $ pageIsTheme page) + _ -> none + ) + += ( case pageType page of + MIMEType "text" "x-rakka" _ + -> sattr "isFeed" (yesOrNo $ pageIsFeed page) + _ -> none + ) + += sattr "isLocked" (yesOrNo $ pageIsLocked page) + += ( case pageRevision page of + Nothing -> none + Just rev -> sattr "revision" (show rev) + ) + += sattr "lastModified" (formatW3CDateTime $ pageLastMod page) + + += ( case pageSummary page of + Nothing -> none + Just s -> eelem "summary" += txt s + ) + + += ( case pageOtherLang page of + [] -> none + xs -> selem "otherLang" + [ eelem "link" + += sattr "lang" lang + += sattr "page" page + | (lang, page) <- xs ] + ) + + += ( case pageIsBinary page of + False -> eelem "content" + += txt (decodeLazy UTF8 $ pageContent page) + + True -> eelem "object" + += sattr "data" (uriToString id (mkObjectURI baseURI $ pageName page) "") + ) + ) + ) -<< () + + returnA -< do let lastMod = toClockTime $ pageLastMod page + + case pageRevision page of + Nothing -> foundTimeStamp lastMod + Just rev -> foundEntity (strongETag $ show rev) lastMod + + outputXmlPage tree entityToXHTML + + +entityToXHTML :: ArrowXml a => a XmlTree XmlTree +entityToXHTML + = eelem "/" + += ( eelem "html" + += sattr "xmlns" "http://www.w3.org/1999/xhtml" + += ( eelem "head" + += ( eelem "title" + += getXPathTreesInDoc "/page/@site/text()" + += txt " - " + += getXPathTreesInDoc "/page/@name/text()" + ) + += ( eelem "base" + += attr "href" + ( getXPathTreesInDoc "/page/@baseURI/text()" ) + ) + += ( eelem "link" + += sattr "rel" "stylesheet" + += sattr "type" "text/css" + += attr "href" + ( txt "./object/" + <+> + getXPathTreesInDoc "/page/@styleSheet/text()" + >>> + getText + >>> + arr encodePageName + >>> + mkText + ) + ) + ) + += ( eelem "body" + += ( eelem "div" + += sattr "class" "header" + ) + += ( eelem "div" + += sattr "class" "center" + += ( eelem "div" + += sattr "class" "title" + ) + += ( eelem "div" + += sattr "class" "body" + += ( getXPathTreesInDoc "/page/content" + `guards` + getXPathTreesInDoc "/page/content/text()" -- FIXME + ) + += ( getXPathTreesInDoc "/page/object" + `guards` + eelem "object" + += attr "data" + ( getXPathTreesInDoc "/page/object/@data/text()" ) + ) + ) + ) + += ( eelem "div" + += sattr "class" "footer" + ) + += ( eelem "div" + += sattr "class" "left side-bar" + += ( eelem "div" + += sattr "class" "content" + ) + ) + += ( eelem "div" + += sattr "class" "right side-bar" + += ( eelem "div" + += sattr "class" "content" + ) + ) + ) + ) diff --git a/Rakka/Storage.hs b/Rakka/Storage.hs index 7a0d0c2..1abace0 100644 --- a/Rakka/Storage.hs +++ b/Rakka/Storage.hs @@ -12,6 +12,7 @@ module Rakka.Storage where import Control.Arrow.ArrowIO +import Control.Monad.Trans import Rakka.Page import Rakka.Storage.DefaultPage import Subversion.Types @@ -20,16 +21,16 @@ import Subversion.Types data Storage = Storage -- FIXME -mkStorage :: IO Storage -- FIXME -mkStorage = return Storage +mkStorage :: Storage -- FIXME +mkStorage = Storage -getPage :: Storage -> PageName -> IO (Maybe Page) +getPage :: MonadIO m => Storage -> PageName -> m (Maybe Page) getPage sto name - = loadDefaultPage name -- FIXME + = liftIO $ loadDefaultPage name -- FIXME -putPage :: Storage -> Maybe RevNum -> Page -> IO () +putPage :: MonadIO m => Storage -> Maybe RevNum -> Page -> m () putPage sto oldRev page = error "FIXME: not implemented" diff --git a/Rakka/Storage/DefaultPage.hs b/Rakka/Storage/DefaultPage.hs index 9cdaf45..5362cc7 100644 --- a/Rakka/Storage/DefaultPage.hs +++ b/Rakka/Storage/DefaultPage.hs @@ -3,11 +3,13 @@ module Rakka.Storage.DefaultPage ) where -import qualified Codec.Binary.Base64.String as B64 +import qualified Codec.Binary.Base64 as B64 import Control.Arrow import Control.Arrow.ArrowIO import Control.Arrow.ArrowList -import qualified Data.ByteString.Lazy.Char8 as L8 +import qualified Data.ByteString.Lazy as L +import Data.Encoding +import Data.Encoding.UTF8 import Paths_Rakka -- Cabal が用意する。 import Rakka.Page import Rakka.Utils @@ -23,13 +25,13 @@ import Text.XML.HXT.DOM.XmlKeywords loadDefaultPage :: PageName -> IO (Maybe Page) loadDefaultPage pageName - -- ./data/Foo を探した後、Cabal で defaultPages/Foo を探す。 - = do let pagePath = encodePageName pageName - isInDataDir <- doesFileExist ("./data/" ++ pagePath) + -- ./defaultPages/Foo を探した後、Cabal で defaultPages/Foo を探す。 + = do let pagePath = "defaultPages/" ++ encodePageName pageName + isInDataDir <- doesFileExist pagePath if isInDataDir then - return . Just =<< loadPageFile pageName ("./data/" ++ pagePath) + return . Just =<< loadPageFile pageName pagePath else - do fpath <- getDataFileName ("defaultPages/" ++ pagePath) + do fpath <- getDataFileName pagePath isInstalled <- doesFileExist fpath if isInstalled then return . Just =<< loadPageFile pageName fpath @@ -79,7 +81,7 @@ parseEntity -> do mimeType <- (getXPathTreesInDoc "/page/@type/text()" >>> getText >>> arr read) -< tree - isTheme <- (maybeA (getXPathTreesInDoc "/page/@type/text()" >>> getText) + isTheme <- (maybeA (getXPathTreesInDoc "/page/@isTheme/text()" >>> getText) >>> defaultTo "no" >>> parseYesOrNo) -< tree isFeed <- (maybeA (getXPathTreesInDoc "/page/@isFeed/text()" >>> getText) @@ -102,12 +104,13 @@ parseEntity &&& getAttrValue0 "page")) -< tree - textData <- maybeA (getXPathTreesInDoc "/page/textData" >>> getText) -< tree - binaryData <- maybeA (getXPathTreesInDoc "/page/binaryData" >>> getText) -< tree + textData <- maybeA (getXPathTreesInDoc "/page/textData/text()" >>> getText) -< tree + binaryData <- maybeA (getXPathTreesInDoc "/page/binaryData/text()" >>> getText) -< tree - let content = case (textData, binaryData) of - (Just text, _ ) -> L8.pack text - (_ , Just binary) -> L8.pack $ B64.decode binary + let (isBinary, content) + = case (textData, binaryData) of + (Just text, _ ) -> (False, encodeLazy UTF8 text ) + (_ , Just binary) -> (True , L.pack $ B64.decode binary) returnA -< Entity { pageName = name @@ -116,6 +119,7 @@ parseEntity , pageIsFeed = isFeed , pageIsLocked = isLocked , pageIsBoring = isBoring + , pageIsBinary = isBinary , pageRevision = Nothing , pageLastMod = lastMod , pageSummary = summary diff --git a/Rakka/SystemConfig.hs b/Rakka/SystemConfig.hs new file mode 100644 index 0000000..ea7e370 --- /dev/null +++ b/Rakka/SystemConfig.hs @@ -0,0 +1,87 @@ +module Rakka.SystemConfig + ( SystemConfig + , SysConfValue(..) + + , mkSystemConfig -- private + + , getSysConf + , getSysConfA + ) + where + +import Control.Arrow.ArrowIO +import Control.Monad.Trans +import qualified Data.ByteString.Char8 as C8 +import Data.Maybe +import Network +import qualified Network.HTTP.Lucu.Config as LC +import Network.URI + + +data SystemConfig = SystemConfig { + scLucuConf :: !LC.Config + } + + +data SysConfValue + = SiteName String + | BaseURI URI + | StyleSheet String + + +mkSystemConfig :: LC.Config -> SystemConfig +mkSystemConfig = SystemConfig + + +getSysConf :: MonadIO m => SystemConfig -> SysConfValue -> m SysConfValue +getSysConf sc key + = liftIO $ sysConfDefault sc key -- FIXME + + +getSysConfA :: ArrowIO a => SystemConfig -> SysConfValue -> a b SysConfValue +getSysConfA = (arrIO0 .) . getSysConf + + +{- paths -} +sysConfPath :: SysConfValue -> FilePath +sysConfPath (SiteName _) = "/siteName" +sysConfPath (BaseURI _) = "/baseURI" +sysConfPath (StyleSheet _) = "/styleSheet" + + +{- marshalling -} +marshalSysConf :: SysConfValue -> String +marshalSysConf (SiteName name) = name +marshalSysConf (BaseURI uri ) = uriToString id uri "" +marshalSysConf (StyleSheet name) = name + + +{- unmarshalling -} +unmarshalSysConf :: SysConfValue -> String -> SysConfValue +unmarshalSysConf (SiteName _) name = SiteName name +unmarshalSysConf (BaseURI _) uri = BaseURI $ fromJust $ parseURI uri +unmarshalSysConf (StyleSheet _) name = StyleSheet name + + +{- getting default value -} +sysConfDefault :: SystemConfig -> SysConfValue -> IO SysConfValue + +sysConfDefault _ (SiteName _) + = return $ SiteName "Rakka" + +sysConfDefault sc (BaseURI _) + = do let conf = scLucuConf sc + host = C8.unpack $ LC.cnfServerHost conf + port = case LC.cnfServerPort conf of + PortNumber num -> fromIntegral num + + defaultURI + = "http://" ++ host ++ + (if port == 80 + then "" + else ':' : show port) ++ "/" + + return $ BaseURI $ fromJust $ parseURI defaultURI + +sysConfDefault _ (StyleSheet _) + = return $ StyleSheet "StyleSheet/Default" diff --git a/Rakka/Utils.hs b/Rakka/Utils.hs index 4da609c..92f3b12 100644 --- a/Rakka/Utils.hs +++ b/Rakka/Utils.hs @@ -1,5 +1,6 @@ module Rakka.Utils - ( parseYesOrNo + ( yesOrNo + , parseYesOrNo , maybeA , defaultTo , deleteIfEmpty @@ -13,6 +14,11 @@ import System.Time import Text.Printf +yesOrNo :: Bool -> String +yesOrNo True = "yes" +yesOrNo False = "no" + + parseYesOrNo :: ArrowChoice a => a String Bool parseYesOrNo = proc str -> do case str of diff --git a/defaultPages/Main_Page b/defaultPages/MainPage similarity index 65% rename from defaultPages/Main_Page rename to defaultPages/MainPage index 1acd8ae..3da51be 100644 --- a/defaultPages/Main_Page +++ b/defaultPages/MainPage @@ -2,8 +2,5 @@ - - - This is the main page. Hello, world! - - \ No newline at end of file + This is the main page. Hello, world! + diff --git a/defaultPages/StyleSheet/Default b/defaultPages/StyleSheet/Default new file mode 100644 index 0000000..b01806f --- /dev/null +++ b/defaultPages/StyleSheet/Default @@ -0,0 +1,30 @@ + + + +* { + padding: 0; + margin: 0; + + list-style-type: none; +} + +body { + background-color: white; +} + +.side-bar ul, .side-bar ol { + margin-top: 0.4em; +} + +.side-bar li + li { + margin-top: 0.2em; +} + +.side-bar ul + h1 { + margin-top: 1.2em; +} + + -- 2.40.0