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
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
}
= 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
, encodePageName
, decodePageName
, mkPageURI
+ , mkObjectURI
)
where
import Network.HTTP.Lucu
import Network.URI
import Subversion.Types
+import System.FilePath
import System.Time
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 する。
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]
+ }
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
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)
import Rakka.Environment
import Rakka.Page
import Rakka.Resource.Page.Get
+import System.FilePath
fallbackPage :: Environment -> [String] -> IO (Maybe ResourceDef)
, 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 ()
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
-
- <page site="CieloNegro"
- baseURI="http://example.org/"
- name="Source"
- redirect="Destination"
- revision="112" -- デフォルトでない場合のみ存在
- lastModified="2000-01-01T00:00:00" />
+-}
+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 の場合]
<page site="CieloNegro"
baseURI="http://example.org/"
+ styleSheet="StyleSheet/Default"
name="Foo/Bar"
type="text/x-rakka"
isTheme="no" -- text/css の場合のみ存在
blah blah...
</summary> -- 存在しない場合もある
- <otherLang>
+ <otherLang> -- 存在しない場合もある
<link lang="ja" page="Bar/Baz" />
</otherLang>
</page>
- [text/* 以外の場合: content 要素の代はりに object 要素]
+ [pageIsBinary が True の場合: content 要素の代はりに object 要素]
<object data="/object/Foo/Bar" /> -- 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"
+ )
+ )
+ )
+ )
where
import Control.Arrow.ArrowIO
+import Control.Monad.Trans
import Rakka.Page
import Rakka.Storage.DefaultPage
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"
)
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
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
-> 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)
&&&
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
, pageIsFeed = isFeed
, pageIsLocked = isLocked
, pageIsBoring = isBoring
+ , pageIsBinary = isBinary
, pageRevision = Nothing
, pageLastMod = lastMod
, pageSummary = summary
--- /dev/null
+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"
module Rakka.Utils
- ( parseYesOrNo
+ ( yesOrNo
+ , parseYesOrNo
, maybeA
, defaultTo
, deleteIfEmpty
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
<page xmlns="http://cielonegro.org/schema/Rakka/Page/1.0"
type="text/x-rakka"
isBoring="yes">
-
- <textData>
- This is the main page. Hello, world!
- </textData>
-</page>
\ No newline at end of file
+ <textData>This is the main page. Hello, world!</textData>
+</page>
--- /dev/null
+<?xml version="1.0" encoding="utf-8"?>
+<page xmlns="http://cielonegro.org/schema/Rakka/Page/1.0"
+ type="text/css"
+ isBoring="yes"
+ isTheme="yes">
+ <textData>
+* {
+ 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;
+}
+</textData>
+</page>
projects / Rakka.git / commitdiff