+ → do SiteName siteName ← getSysConfA (envSysConf env) ⤙ ()
+ BaseURI baseURI ← getSysConfA (envSysConf env) ⤙ ()
+ StyleSheet styleSheet ← getSysConfA (envSysConf env) ⤙ ()
+ GlobalLock isGLocked ← getSysConfA (envSysConf env) ⤙ ()
+
+ let cssHref = [uriToString id (mkObjectURI baseURI styleSheet) ""]
+ scriptSrc = [uriToString id (baseURI { uriPath = uriPath baseURI </> "js" }) ""]
+
+ pageTitle ← listA (readSubPage env) ⤙ "PageTitle"
+ leftSideBar ← listA (readSubPage env) ⤙ "SideBar/Left"
+ rightSideBar ← listA (readSubPage env) ⤙ "SideBar/Right"
+
+ ( eelem "/"
+ += ( eelem "html"
+ += sattr "xmlns" "http://www.w3.org/1999/xhtml"
+ += ( eelem "head"
+ += ( eelem "title"
+ += txt (T.unpack siteName)
+ += txt " - "
+ += getXPathTreesInDoc "/searchResult/@query/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 ⊕ ";" )
+ += txt "Rakka.isSpecialPage=true;" ) )
+ += ( 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 "h1"
+ += txt "Search Result"
+ )
+ += ( eelem "div"
+ += sattr "class" "searchStat"
+ += txt "Search result for "
+ += ( eelem "span"
+ += sattr "class" "queryString"
+ += getXPathTreesInDoc "/searchResult/@query/text()"
+ )
+ += txt ": found "
+ += getXPathTreesInDoc "/searchResult/@total/text()"
+ += txt " pages."
+ )
+ += ( getXPathTreesInDoc "/searchResult/page"
+ ⋙
+ formatItem baseURI
+ )
+ += ( ( ( getXPathTreesInDoc "/searchResult/@query/text()"
+ ⋙
+ getText
+ )
+ &&&
+ maybeA ( getXPathTreesInDoc "/searchResult/@order/text()"
+ ⋙
+ getText
+ )
+ &&&
+ ( getXPathTreesInDoc "/searchResult/@from/text()"
+ ⋙
+ getText
+ ⋙
+ arr ((`div` resultsPerSection) . read)
+ )
+ &&&
+ ( getXPathTreesInDoc "/searchResult/@total/text()"
+ ⋙
+ getText
+ ⋙
+ arr ((+ 1) . (`div` resultsPerSection) . (\x → x - 1) . read) ) )
+ ⋙
+ ( ((> 1) . snd . snd . snd)
+ `guardsP`
+ formatPager baseURI ) ) ) )
+ += ( 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
+ ) ) ⤛ tree
+ where
+ formatItem ∷ (ArrowXml (⇝), ArrowChoice (⇝), ArrowIO (⇝))
+ ⇒ URI
+ → XmlTree ⇝ XmlTree
+ formatItem baseURI
+ = ( eelem "div"
+ += sattr "class" "searchResult"
+ += ( eelem "a"
+ += attr "href" ( getAttrValue "name"
+ ⋙
+ arr (\x → uriToString id (mkPageURI baseURI (T.pack x)) "")
+ ⋙
+ mkText
+ )
+ += (getAttrValue "name" ⋙ mkText)
+ )
+ += ( eelem "div"
+ += sattr "class" "date"
+ += ( getAttrValue "lastModified"
+ ⋙
+ arr (zonedTimeToUTC . fromJust . W3C.parse)
+ ⋙
+ arrIO utcToLocalZonedTime
+ ⋙
+ arr RFC1123.format
+ ⋙
+ mkText
+ )
+ )
+ += ( eelem "p"
+ += ( getChildren
+ ⋙
+ choiceA [ isText :-> this
+ , hasName "boundary" :-> txt " ... "
+ , hasName "hit" :-> ( eelem "span"
+ += sattr "class" "highlighted"
+ += getChildren
+ )
+ ]
+ )
+ )
+ )
+
+ formatPager :: (ArrowChoice a, ArrowXml a) => URI -> a (String, (Maybe String, (Int, Int))) XmlTree
+ formatPager baseURI
+ = ( eelem "div"
+ += sattr "class" "pager"
+ += txt "Page."
+ += ( ( arr fst
+ &&&
+ arr (fst . snd)
+ &&&
+ arr (fst . snd . snd)
+ &&&
+ ( arr (snd . snd)
+ ⋙
+ mkSectionWindow
+ )
+ )
+ ⋙
+ proc (query, (order, (currentSection, section)))
+ -> if currentSection == section then
+ ( txt " "
+ <+>
+ eelem "span"
+ += sattr "class" "currentSection"
+ += (arr show ⋙ mkText)
+ ) ⤙ section
+ else
+ ( txt " "
+ <+>
+ eelem "a"
+ += attr "href" ( mkSectionURI baseURI
+ ⋙
+ uriToText
+ )
+ += (arr (show . snd . snd) ⋙ mkText)
+ ) ⤙ (query, (order, section))
+ )
+ )
+
+ mkSectionWindow :: ArrowList a => a (Int, Int) Int
+ mkSectionWindow
+ = proc (currentSection, totalSections)
+ -> let windowWidth = min maxSectionWindowSize totalSections
+ windowBegin = currentSection - (windowWidth `div` 2)
+ (begin, end) = if windowBegin < 0 then
+ -- 左に溢れた
+ (0, windowWidth - 1)
+ else
+ if windowBegin + windowWidth >= totalSections then
+ -- 右に溢れた
+ (totalSections - windowWidth, totalSections - 1)
+ else
+ -- どちらにも溢れない
+ (windowBegin, windowBegin + windowWidth - 1)
+ in
+ arrL id ⤙ [begin .. end]
+
+
+ mkSectionURI :: Arrow a => URI -> a (String, (Maybe String, Int)) URI
+ mkSectionURI baseURI
+ = arr $ \ (query, (order, section))
+ -> baseURI {
+ uriPath = uriPath baseURI </> "search.html"
+ , uriQuery = '?' : C8.unpack (mkQueryString ( [ ("q" , T.pack query)
+ , ("from", T.pack ∘ show $ section ⋅ resultsPerSection )
+ , ("to" , T.pack ∘ show $ (section + 1) ⋅ resultsPerSection - 1)
+ ]
+ ++
+ case order of
+ Just o -> [("order", T.pack o)]
+ Nothing -> []
+ ))
+ }
+
+ uriToText :: ArrowXml a => a URI XmlTree
+ uriToText = arr (\ uri -> uriToString id uri "") ⋙ mkText
+
+
+-- FIXME: localize
+readSubPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
+ Environment -> a PageName XmlTree
+readSubPage env
+ = proc (subPageName) ->
+ do subPage ← getPageA (envStorage env) ⋙ arr fromJust ⋙ xmlizePage ⤙ (subPageName, Nothing)
+ subXHTML ← makeSubXHTML (envStorage env) (envSysConf env) (envInterpTable env) ⤙ (Nothing, Nothing, subPage)
+ returnA ⤙ subXHTML