import Control.Arrow.ArrowIO
import Control.Arrow.ArrowIf
import Control.Arrow.ArrowList
+import Control.Monad.Trans
import Data.Char
import Data.Maybe
import Network.HTTP.Lucu
import Rakka.Resource
import Rakka.Storage
import Rakka.SystemConfig
+import Rakka.Utils
import Rakka.Wiki.Engine
import System.FilePath
+import Text.XML.HXT.Arrow.Namespace
+import Text.XML.HXT.Arrow.WriteDocument
import Text.XML.HXT.Arrow.XmlArrow
+import Text.XML.HXT.Arrow.XmlIOStateArrow
import Text.XML.HXT.Arrow.XmlNodeSet
import Text.XML.HXT.DOM.TypeDefs
+import Text.XML.HXT.DOM.XmlKeywords
fallbackPageEntity :: Environment -> [String] -> IO (Maybe ResourceDef)
= return $ Just $ ResourceDef {
resUsesNativeThread = False
, resIsGreedy = True
- , resGet = Just $ handleGet env (toPageName path)
+ , resGet = Just $ handleGet env (toPageName path)
, resHead = Nothing
, resPost = Nothing
- , resPut = Just $ handlePut env (toPageName path)
- , resDelete = Nothing
+ , resPut = Just $ handlePut env (toPageName path)
+ , resDelete = Just $ handleDelete env (toPageName path)
}
where
toPageName :: [String] -> PageName
-> do pageM <- getPageA (envStorage env) -< (name, Nothing)
case pageM of
Nothing
- -> handlePageNotFound env -< name
+ -> do items <- getDirContentsA (envStorage env) -< (name, Nothing)
+ case items of
+ [] -> handlePageNotFound env -< name
+ _ -> handleGetPageListing env -< (name, items)
+ Just page
+ -> if isEntity page then
+ handleGetEntity env -< page
+ else
+ handleRedirect env -< page
- Just redir@(Redirection _ _ _ _ _)
- -> handleRedirect env -< redir
-
- Just entity@(Entity _ _ _ _ _ _ _ _ _ _ _ _ _ _ _)
- -> handleGetEntity env -< entity
{-
HTTP/1.1 302 Found
- Location: http://example.org/Destination#Redirect:Source
+ Location: http://example.org/Destination.html#Redirect:Source
-}
handleRedirect :: (ArrowXml a, ArrowIO a) => Environment -> a Page (Resource ())
handleRedirect env
= proc redir
- -> do BaseURI baseURI <- getSysConfA (envSysConf env) -< ()
- returnA -< redirect Found (mkPageURI baseURI $ redirDest redir) -- FIXME
+ -> returnA -< do mType <- getEntityType
+ case mType of
+ MIMEType "application" "xhtml+xml" _
+ -> do BaseURI baseURI <- getSysConf (envSysConf env)
+ let uri = mkPageFragmentURI
+ baseURI
+ (redirDest redir)
+ ("Redirect:" ++ redirName redir)
+ redirect Found uri
+
+ MIMEType "text" "xml" _
+ -> do setContentType mType
+ [resultStr] <- liftIO $ runX ( setErrorMsgHandler False fail
+ >>>
+ constA redir
+ >>>
+ xmlizePage
+ >>>
+ writeDocumentToString [ (a_indent, v_1) ]
+ )
+ output resultStr
+
+ _ -> fail ("internal error: getEntityType returned " ++ show mType)
handleGetEntity :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a Page (Resource ())
-> do SiteName siteName <- getSysConfA (envSysConf env) -< ()
BaseURI baseURI <- getSysConfA (envSysConf env) -< ()
StyleSheet styleSheet <- getSysConfA (envSysConf env) -< ()
+ GlobalLock isGLocked <- getSysConfA (envSysConf env) -< ()
- name <- (getXPathTreesInDoc "/page/@name/text()" >>> getText) -< page
+ name <- (getXPathTreesInDoc "/page/@name/text()" >>> getText) -< page
+ isLocked <- (getXPathTreesInDoc "/page/@isLocked/text()" >>> getText >>> parseYesOrNo) -< page
let cssHref = [uriToString id (mkObjectURI baseURI styleSheet) ""]
scriptSrc = [uriToString id (baseURI { uriPath = uriPath baseURI </> "js" }) ""]
+= sattr "type" "text/javascript"
+= attr "src" (arr id >>> mkText)
)
+ += ( eelem "script"
+ += sattr "type" "text/javascript"
+ += txt ("Rakka.baseURI=\"" ++ uriToString id baseURI "" ++ "\";")
+ += txt ("Rakka.isLocked=" ++ trueOrFalse isLocked ++ ";")
+ += txt ("Rakka.isGlobalLocked=" ++ trueOrFalse isGLocked ++ ";")
+ )
)
+= ( eelem "body"
+= ( eelem "div"
)
)
)
+ >>>
+ uniqueNamespacesFromDeclAndQNames
) ) -<< page
returnA -< subXHTML
+{-
+ <pageListing path="Foo">
+ <page name="Foo/Bar" />
+ <page name="Foo/Baz" />
+ </pageListing>
+-}
+handleGetPageListing :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a (PageName, [PageName]) (Resource ())
+handleGetPageListing env
+ = proc (dir, items)
+ -> do tree <- ( eelem "/"
+ += ( eelem "pageListing"
+ += attr "path" (arr fst >>> mkText)
+ += ( arrL snd
+ >>>
+ ( eelem "page"
+ += attr "name" (arr id >>> mkText)
+ )
+ )
+ )
+ ) -< (dir, items)
+ returnA -< outputXmlPage tree (pageListingToXHTML env)
+
+
+pageListingToXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a XmlTree XmlTree
+pageListingToXHTML env
+ = proc pageListing
+ -> do SiteName siteName <- getSysConfA (envSysConf env) -< ()
+ BaseURI baseURI <- getSysConfA (envSysConf env) -< ()
+ StyleSheet styleSheet <- getSysConfA (envSysConf env) -< ()
+ GlobalLock isGLocked <- getSysConfA (envSysConf env) -< ()
+
+ name <- (getXPathTreesInDoc "/pageListing/@path/text()" >>> getText) -< pageListing
+
+ let cssHref = [uriToString id (mkObjectURI baseURI styleSheet) ""]
+ scriptSrc = [uriToString id (baseURI { uriPath = uriPath baseURI </> "js" }) ""]
+
+ pageTitle <- listA (readSubPage env) -< (name, Nothing, "PageTitle")
+ leftSideBar <- listA (readSubPage env) -< (name, Nothing, "SideBar/Left")
+ rightSideBar <- listA (readSubPage env) -< (name, Nothing, "SideBar/Right")
+
+ ( eelem "/"
+ += ( eelem "html"
+ += sattr "xmlns" "http://www.w3.org/1999/xhtml"
+ += ( eelem "head"
+ += ( eelem "title"
+ += txt siteName
+ += txt " - "
+ += getXPathTreesInDoc "/pageListing/@path/text()"
+ )
+ += ( constL cssHref
+ >>>
+ eelem "link"
+ += sattr "rel" "stylesheet"
+ += sattr "type" "text/css"
+ += attr "href" (arr id >>> mkText)
+ )
+ += ( constL scriptSrc
+ >>>
+ eelem "script"
+ += sattr "type" "text/javascript"
+ += attr "src" (arr id >>> mkText)
+ )
+ += ( eelem "script"
+ += sattr "type" "text/javascript"
+ += txt ("Rakka.baseURI = \"" ++ uriToString id baseURI "" ++ "\";")
+ += txt ("Rakka.isGlobalLocked=" ++ trueOrFalse isGLocked ++ ";")
+ )
+ )
+ += ( eelem "body"
+ += ( eelem "div"
+ += sattr "class" "header"
+ )
+ += ( eelem "div"
+ += sattr "class" "center"
+ += ( eelem "div"
+ += sattr "class" "title"
+ += constL pageTitle
+ )
+ += ( eelem "div"
+ += sattr "class" "body"
+ += ( eelem "ul"
+ += ( getXPathTreesInDoc "/pageListing/page/@name/text()"
+ >>>
+ eelem "li"
+ += ( eelem "a"
+ += attr "href" ( getText
+ >>>
+ arr (\ x -> uriToString id (mkPageURI baseURI x) "")
+ >>>
+ mkText
+ )
+ += this
+ )
+ )
+ )
+ )
+ )
+ += ( eelem "div"
+ += sattr "class" "footer"
+ )
+ += ( eelem "div"
+ += sattr "class" "left sideBar"
+ += ( eelem "div"
+ += sattr "class" "content"
+ += constL leftSideBar
+ )
+ )
+ += ( eelem "div"
+ += sattr "class" "right sideBar"
+ += ( eelem "div"
+ += sattr "class" "content"
+ += constL rightSideBar
+ )
+ )
+ )
+ >>>
+ uniqueNamespacesFromDeclAndQNames
+ ) ) -<< pageListing
+
+
{-
<pageNotFound name="Foo/Bar" />
-}
-> do SiteName siteName <- getSysConfA (envSysConf env) -< ()
BaseURI baseURI <- getSysConfA (envSysConf env) -< ()
StyleSheet styleSheet <- getSysConfA (envSysConf env) -< ()
+ GlobalLock isGLocked <- getSysConfA (envSysConf env) -< ()
name <- (getXPathTreesInDoc "/pageNotFound/@name/text()" >>> getText) -< pageNotFound
+= sattr "type" "text/javascript"
+= attr "src" (arr id >>> mkText)
)
+ += ( eelem "script"
+ += sattr "type" "text/javascript"
+ += txt ("Rakka.baseURI = \"" ++ uriToString id baseURI "" ++ "\";")
+ += txt ("Rakka.isGlobalLocked=" ++ trueOrFalse isGLocked ++ ";")
+ )
)
+= ( eelem "body"
+= ( eelem "div"
)
)
)
+ >>>
+ uniqueNamespacesFromDeclAndQNames
) ) -<< pageNotFound
handlePut :: Environment -> PageName -> Resource ()
handlePut env name
- = runXmlA env "rakka-page-1.0.rng" $ proc tree
- -> do page <- parseXmlizedPage -< (name, tree)
- status <- putPageA (envStorage env) -< page
- returnA -< setStatus status
+ = do userID <- getUserID env
+ runXmlA env "rakka-page-1.0.rng" $ proc tree
+ -> do page <- parseXmlizedPage -< (name, tree)
+ status <- putPageA (envStorage env) -< (userID, page)
+ returnA -< setStatus status
+
+
+handleDelete :: Environment -> PageName -> Resource ()
+handleDelete env name
+ = do userID <- getUserID env
+ status <- deletePage (envStorage env) userID name
+ setStatus status
projects / Rakka.git / blobdiff