Setup
dist/
+.ditz-config
+
Rakka/Resource/JavaScript.hs
js/packed.js
js/yuicompressor-*.jar
import Data.Maybe
import Network.Socket
import Network.HTTP.Lucu
-import OpenSSL
+import OpenSSL
import Rakka.Environment
import Rakka.Resource.CheckAuth
import Rakka.Resource.DumpRepos
import Rakka.Resource.Render
import Rakka.Resource.Search
import Rakka.Resource.SystemConfig
--- import Rakka.Resource.TrackBack
import Rakka.Resource.Users
import Rakka.Storage
import Subversion
-import System.Console.GetOpt
+import System.Console.GetOpt -- FIXME: Use better library than this.
import System.Directory
import System.Environment
import System.Exit
, (["search.html" ], resSearch env)
, (["search.xml" ], resSearch env)
, (["systemConfig"], resSystemConfig env)
- -- , (["trackback" ], resTrackBack env)
, (["users" ], resUsers env)
]
Maintainer: PHO <pho at cielonegro dot org>
Stability: experimental
Homepage: http://rakka.cielonegro.org/
+Bug-Reports: http://static.cielonegro.org/ditz/Rakka/
Category: Web
Tested-With: GHC == 6.12.1
Cabal-Version: >= 1.6
Build-Type: Custom
+
Data-Files:
defaultPages/Feed.xml
defaultPages/Help/SampleImage/Large.xml
defaultPages/StyleSheet/Default.xml
rc.d/NetBSD/rakka.in
schemas/rakka-page-1.0.rng
+
Extra-Source-Files:
Rakka.buildinfo.in
configure
Executable rakka
Build-Depends:
+ HsHyperEstraier == 0.4.*,
+ HsOpenSSL == 0.10.*,
+ HsSVN == 0.4.*,
+ Lucu == 0.7.*,
+ base == 4.*,
base-unicode-symbols == 0.2.*,
+ bytestring == 0.9.*,
case-insensitive == 0.4.*,
+ containers == 0.4.*,
+ dataenc == 0.14.*,
+ directory == 1.1.*,
filemanip == 0.3.*,
- text == 0.11.*,
+ filepath == 1.2.*,
+ hslogger == 1.1.*,
+ hxt == 9.2.*,
hxt-relaxng == 9.1.*,
+ hxt-xpath == 9.1.*,
+ magic == 1.0.*,
+ mtl == 2.0.*,
+ network == 2.3.*,
+ parsec == 3.1.*,
+ stm == 2.2.*,
+ text == 0.11.*,
+ time == 1.2.*,
time-http == 0.1.*,
- HTTP, HUnit, HsHyperEstraier, HsOpenSSL, HsSVN >=
- 0.3.2, Lucu, base, bytestring, containers, dataenc, directory,
- utf8-string, filepath, hslogger, hxt, hxt-xpath, magic, mtl,
- network, parsec, stm, time, unix, zlib
+ time-w3c == 0.1.*,
+ unix == 2.4.*,
+ utf8-string == 0.3.*,
+ zlib == 0.5.*
Main-Is:
Main.hs
Rakka.Resource.Render
Rakka.Resource.Search
Rakka.Resource.SystemConfig
- Rakka.Resource.TrackBack
Rakka.Resource.Users
Rakka.Storage
Rakka.Storage.DefaultPage
Rakka.Storage.Types
Rakka.Storage.Impl
Rakka.SystemConfig
- Rakka.TrackBack
Rakka.Utils
Rakka.Validation
- Rakka.W3CDateTime
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
Executable RakkaUnitTest
if flag(build-test-suite)
Buildable: True
+ Build-Depends: HUnit
else
Buildable: False
+
Main-Is:
RakkaUnitTest.hs
+
Hs-Source-Dirs:
., tests
+
Other-Modules:
WikiParserTest
+
GHC-Options:
-Wall -Werror
import qualified Rakka.Wiki.Interpreter.Base as Base
import qualified Rakka.Wiki.Interpreter.Image as Image
import qualified Rakka.Wiki.Interpreter.PageList as PageList
---import qualified Rakka.Wiki.Interpreter.Trackback as Trackback
import qualified Rakka.Wiki.Interpreter.Outline as Outline
import Subversion.Repository
import System.Directory
concat [ Base.interpreters
, Image.interpreters
, PageList.interpreters
- --, Trackback.interpreters
, Outline.interpreters
]
where
import qualified Data.Text as T
import Data.Text.Encoding
import Data.Time
+import qualified Data.Time.W3C as W3C
import Network.HTTP.Lucu hiding (redirect)
import Network.URI hiding (fragment)
-import OpenSSL.EVP.Base64
+import OpenSSL.EVP.Base64
import Prelude.Unicode
import Rakka.Utils
-import Rakka.W3CDateTime
import Subversion.Types
import System.FilePath.Posix
import Text.XML.HXT.Arrow.XmlArrow
type LanguageTag = CI Text -- See RFC 3066: http://www.ietf.org/rfc/rfc3066.txt
type LanguageName = Text -- i.e. "日本語"
-
data Page
= Redirection {
redirName :: !PageName
}
deriving (Show, Eq)
-
data UpdateInfo
= UpdateInfo {
uiOldRevision :: !RevNum
+= sattr "redirect" (T.unpack $ redirDest page )
+= sattr "isLocked" (yesOrNo $ redirIsLocked page)
+= sattr "revision" (show $ redirRevision page)
- += sattr "lastModified" (formatW3CDateTime lastMod)
+ += sattr "lastModified" (W3C.format lastMod)
)) -<< ()
xmlizeEntity :: (ArrowXml a, ArrowChoice a, ArrowIO a) => a Page XmlTree
+= sattr "isLocked" (yesOrNo $ entityIsLocked page)
+= sattr "isBinary" (yesOrNo $ entityIsBinary page)
+= sattr "revision" (show $ entityRevision page)
- += sattr "lastModified" (formatW3CDateTime lastMod)
+ += sattr "lastModified" (W3C.format lastMod)
+= ( case entitySummary page of
Just s -> eelem "summary" += txt s
Nothing -> none
, entityContent = content
, entityUpdateInfo = updateInfo
}
- where
- dropWhitespace :: String -> String
- dropWhitespace [] = []
- dropWhitespace (x:xs)
- | x == ' ' || x == '\t' || x == '\n'
- = dropWhitespace xs
- | otherwise
- = x : dropWhitespace xs
parseUpdateInfo ∷ (ArrowXml (⇝), ArrowChoice (⇝)) ⇒ XmlTree ⇝ UpdateInfo
parseUpdateInfo
uiOldRevision = oldRev
, uiOldName = T.pack <$> oldName
}
+
+dropWhitespace :: String -> String
+{-# INLINE dropWhitespace #-}
+dropWhitespace = filter ((¬) ∘ isSpace)
import Data.Monoid.Unicode
import qualified Data.Text as T
import Data.Time
+import qualified Data.Time.W3C as W3C
import Network.HTTP.Lucu
import Network.URI hiding (path)
import Prelude.Unicode
import Rakka.Storage
import Rakka.SystemConfig
import Rakka.Utils
-import Rakka.W3CDateTime
import Rakka.Wiki.Engine
import System.FilePath.Posix
import Text.HyperEstraier hiding (getText)
+= sattr "xmlns" "http://purl.org/rss/1.0/"
+= sattr "xmlns:rdf" "http://www.w3.org/1999/02/22-rdf-syntax-ns#"
+= sattr "xmlns:dc" "http://purl.org/dc/elements/1.1/"
- += sattr "xmlns:trackback" "http://madskills.com/public/xml/rss/module/trackback/"
+= ( eelem "channel"
+= sattr "rdf:about" (uriToString id (mkFeedURI baseURI (T.pack name)) "")
+= ( eelem "title"
+= ( eelem "dc:date"
+= ( arrIO (utcToLocalZonedTime . entityLastMod)
⋙
- arr formatW3CDateTime
+ arr W3C.format
⋙
mkText
)
)
- += ( eelem "trackback:ping"
- += attr "rdf:resource" (arr (mkTrackbackURIStr baseURI . entityName) ⋙ mkText)
- )
)
⋙
uniqueNamespacesFromDeclAndQNames
mkPageURIStr baseURI name
= uriToString id (mkPageURI baseURI name) ""
- mkTrackbackURIStr :: URI → PageName → String
- mkTrackbackURIStr baseURI name
- = uriToString id (mkAuxiliaryURI baseURI ["trackback"] name) ""
-
readSubPage ∷ (ArrowXml (⇝), ArrowChoice (⇝), ArrowIO (⇝))
⇒ Environment
→ (PageName, Maybe XmlTree, PageName) ⇝ XmlTree
import Control.Arrow.Unicode
import qualified Codec.Binary.UTF8.Generic as UTF8
import Control.Monad.Trans
+import qualified Data.ByteString.Char8 as C8
import Data.Maybe
import Data.Monoid.Unicode
import Data.Text (Text)
import qualified Data.Text as T
import Data.Time
import qualified Data.Time.RFC1123 as RFC1123
+import qualified Data.Time.W3C as W3C
import Network.HTTP.Lucu
import Network.URI hiding (query, fragment)
import Prelude.Unicode
import Rakka.Storage
import Rakka.SystemConfig
import Rakka.Utils
-import Rakka.W3CDateTime
import Rakka.Wiki.Engine
import System.FilePath
import Text.HyperEstraier hiding (getText)
+= attr "name" (arr (T.unpack ∘ hpPageName) ⋙ mkText)
+= attr "lastModified" ( arrIO (utcToLocalZonedTime ∘ hpLastMod)
⋙
- arr formatW3CDateTime
+ arr W3C.format
⋙
mkText
)
+= sattr "class" "date"
+= ( getAttrValue "lastModified"
⋙
- arr (zonedTimeToUTC . fromJust . parseW3CDateTime)
+ arr (zonedTimeToUTC . fromJust . W3C.parse)
⋙
arrIO utcToLocalZonedTime
⋙
= arr $ \ (query, (order, section))
-> baseURI {
uriPath = uriPath baseURI </> "search.html"
- , uriQuery = '?' : mkQueryString ( [ ("q" , query)
- , ("from", show $ section * resultsPerSection)
- , ("to" , show $ (section + 1) * resultsPerSection - 1)
- ]
- ++
- case order of
- Just o -> [("order", o)]
- Nothing -> []
- )
+ , 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
+++ /dev/null
-module Rakka.Resource.TrackBack
- ( resTrackBack
- )
- where
-
-import qualified Codec.Binary.UTF8.String as UTF8
-import Control.Arrow
-import Control.Arrow.ArrowList
-import Control.Monad.Trans
-import Data.List
-import Data.Maybe
-import Data.Time
-import Network.Browser
-import Network.HTTP
-import Network.HTTP.Lucu
-import Network.HTTP.Lucu.Response
-import Network.URI
-import Rakka.Environment
-import Rakka.Page
-import Rakka.Storage
-import Rakka.SystemConfig
-import Rakka.TrackBack
-import Text.XML.HXT.Arrow.WriteDocument
-import Text.XML.HXT.Arrow.XmlArrow
-import Text.XML.HXT.Arrow.XmlIOStateArrow
-import Text.XML.HXT.DOM.TypeDefs
-import Text.XML.HXT.DOM.XmlKeywords
-
-
-data TBResponse
- = NoError
- | Error !Int !String
- deriving (Show, Eq)
-
-
-resTrackBack :: Environment -> ResourceDef
-resTrackBack env
- = ResourceDef {
- resUsesNativeThread = False
- , resIsGreedy = True
- , resGet = Nothing
- , resHead = Nothing
- , resPost = Just $ getPathInfo >>= handlePost env . toPageName
- , resPut = Nothing
- , resDelete = Nothing
- }
- where
- toPageName :: [String] -> PageName
- toPageName = UTF8.decodeString . joinPath
-
-
-handlePost :: Environment -> PageName -> Resource ()
-handlePost env name
- = do form <- inputForm defaultLimit
- tbParamM <- validateTrackBack form
- case tbParamM of
- Nothing
- -> return ()
- Just tbParam
- -> do cited <- liftIO $ checkCitation tbParam name
- if cited then
- do pageM <- getPage (envStorage env) name Nothing
- case pageM of
- Nothing -> setStatus NotFound
- Just page -> addTB tbParam page
- else
- outputResponse (Error 1 "Failed to confirm if your entry contains any citation to this page.")
- where
- addTB :: TrackBack -> Page -> Resource ()
- addTB tbParam page
- | isRedirect page
- = do BaseURI baseURI <- getSysConf (envSysConf env)
- redirect TemporaryRedirect (mkPageURI baseURI $ redirName page)
- | otherwise
- = do tbListM <- return . fromMaybe [] =<< getAttachment (envStorage env) (pageName page) "trackbacks" Nothing
- st <- putAttachment (envStorage env) Nothing Nothing (pageName page) "trackbacks" (tbParam : tbListM)
- if isSuccessful st then
- outputResponse NoError
- else
- setStatus st
-
-
-validateTrackBack :: [(String, String)] -> Resource (Maybe TrackBack)
-validateTrackBack form
- = do let title = get' "title"
- excerpt = get' "excerpt"
- blogName = get' "blog_name"
- case get' "url" of
- Nothing
- -> do outputResponse (Error 1 "Parameter `url' is missing.")
- return Nothing
- Just u
- -> case parseURI u of
- Nothing
- -> do outputResponse (Error 1 "Parameter `url' is malformed.")
- return Nothing
- Just url
- -> do time <- liftIO getCurrentTime
- return $ Just TrackBack {
- tbTitle = title
- , tbExcerpt = excerpt
- , tbURL = url
- , tbBlogName = blogName
- , tbTime = time
- }
- where
- get' :: String -> Maybe String
- get' = fmap UTF8.decodeString . flip lookup form
-
-
-outputResponse :: TBResponse -> Resource ()
-outputResponse res
- = do setContentType $ read "text/xml"
- [xmlStr] <- liftIO $ runX ( setErrorMsgHandler False fail
- >>>
- mkResponseTree
- >>>
- writeDocumentToString [ (a_indent , v_1 )
- , (a_output_encoding, utf8)
- , (a_no_xml_pi , v_0 ) ]
- )
- output $ UTF8.encodeString xmlStr
- where
- mkResponseTree :: ArrowXml a => a b XmlTree
- mkResponseTree
- = proc _
- -> ( eelem "/"
- += ( eelem "response"
- += ( eelem "error"
- += txt (case res of
- NoError -> "0"
- Error code _ -> show code)
- )
- += ( case res of
- NoError -> none
- Error _ msg -> ( eelem "message"
- += txt msg
- )
- )
- )
- ) -< ()
-
-
-checkCitation :: TrackBack -> PageName -> IO Bool
-checkCitation param name
- = do (_, res) <- browse $
- do setAllowRedirects True
- setErrHandler (\ _ -> return ())
- setOutHandler (\ _ -> return ())
- request $ defaultGETRequest $ tbURL param
- case rspCode res of
- (2, 0, 0)
- -> return (encodePageName name `isInfixOf` rspBody res)
- _ -> return False
import Data.Text (Text)
import qualified Data.Text as T
import Data.Time
+import qualified Data.Time.W3C as W3C
import Network.HTTP.Lucu
import Network.HTTP.Lucu.Utils
import Network.URI
import Rakka.Storage.DefaultPage
import Rakka.Storage.Repos
import Rakka.Storage.Types
-import Rakka.W3CDateTime
import Subversion.Types
import Subversion.FileSystem
import Subversion.Repository
read ∘ T.unpack ∘ fromJust
<$> getDocAttr index docId "rakka:revision"
lastMod ← unsafeInterleaveIO $
- zonedTimeToUTC ∘ fromJust ∘ parseW3CDateTime ∘ T.unpack ∘ fromJust
+ zonedTimeToUTC ∘ fromJust ∘ W3C.parse ∘ T.unpack ∘ fromJust
<$> getDocAttr index docId "@mdate"
summary ← unsafeInterleaveIO $
getDocAttr index docId "rakka:summary"
import qualified Data.Set as S hiding (Set)
import qualified Data.Text as T
import Data.Time
+import qualified Data.Time.W3C as W3C
import Network.HTTP.Lucu hiding (redirect)
import Prelude.Unicode
import Rakka.Attachment
import Rakka.Page
import Rakka.SystemConfig
import Rakka.Utils
-import Rakka.W3CDateTime
import Subversion.FileSystem
import Subversion.FileSystem.DirEntry
import Subversion.FileSystem.Revision
$ fmap chomp (lookup "svn:mime-type" props)
lastMod <- unsafeIOToFS $
- liftM (fromJust . parseW3CDateTime . chomp . fromJust)
+ liftM (fromJust . W3C.parse . chomp . fromJust)
(getRevisionProp' fs pageRev "svn:date")
return Entity {
dest = T.pack ∘ chomp $ decodeString content
lastMod <- unsafeIOToFS $
- liftM (fromJust . parseW3CDateTime . chomp . fromJust)
+ liftM (fromJust . W3C.parse . chomp . fromJust)
(getRevisionProp' fs pageRev "svn:date")
isLocked <- liftM isJust (getNodeProp path "rakka:isLocked")
defaultValue sc
= let conf = scLucuConf sc
host = C8.unpack $ LC.cnfServerHost conf
- port = unsafePerformIO ∘ getServicePortNumber $ LC.cnfServerPort conf
+ port = unsafePerformIO $
+ do ent <- getServiceByName (LC.cnfServerPort conf) "tcp"
+ return (servicePort ent)
+ -- FIXME: There should be a way to change configurations
+ -- without web interface nor direct repository
+ -- modification.
defaultURI
- = "http://" ++ host ++ -- FIXME: consider IPv6 address
+ = "http://" ++ host ++
(if port == 80
then ""
else ':' : show port) ++ "/"
+++ /dev/null
-module Rakka.TrackBack
- ( TrackBack(..)
- )
- where
-
-import Data.Maybe
-import Data.Time
-import Network.URI
-import Rakka.Attachment
-import Rakka.Utils
-import Rakka.W3CDateTime
-import Text.XML.HXT.Arrow
-import Text.XML.HXT.DOM.TypeDefs
-
-
-data TrackBack
- = TrackBack {
- tbTitle :: !(Maybe String)
- , tbExcerpt :: !(Maybe String)
- , tbURL :: !URI
- , tbBlogName :: !(Maybe String)
- , tbTime :: !UTCTime
- }
- deriving (Show, Eq)
-
-
-{-
- <trackbacks>
- <trackback title="" url="" blogName="" time="">
- excerpt...
- </trackback>
- ...
- </trackbacks>
--}
-instance Attachment [TrackBack] where
- serializeToXmlTree
- = proc trackbacks
- -> ( eelem "/"
- += ( eelem "trackbacks"
- += ( arrL id
- >>>
- tbToTree
- )
- )
- ) -< trackbacks
- where
- tbToTree :: ArrowXml a => a TrackBack XmlTree
- tbToTree
- = proc tb
- -> let title = case tbTitle tb of
- Nothing -> none
- Just t -> sattr "title" t
- excerpt = case tbExcerpt tb of
- Nothing -> none
- Just e -> txt e
- url = sattr "url" (uriToString id (tbURL tb) "")
- blogName = case tbBlogName tb of
- Nothing -> none
- Just n -> sattr "blogName" n
- time = sattr "time" (formatW3CDateTime $ utcToZonedTime utc (tbTime tb))
- in
- ( eelem "trackback"
- += title
- += url
- += blogName
- += time
- += excerpt
- ) -<< ()
-
- deserializeFromXmlTree
- = proc doc -> listA (getXPathTreesInDoc "/trackbacks/trackback" >>> treeToTb) -< doc
- where
- treeToTb :: (ArrowChoice a, ArrowXml a) => a XmlTree TrackBack
- treeToTb
- = proc tree
- -> do title <- maybeA (getAttrValue0 "title") -< tree
- url <- ( getAttrValue0 "url"
- >>>
- arr (fromJust . parseURI)
- ) -< tree
- time <- ( getAttrValue0 "time"
- >>>
- arr (zonedTimeToUTC . fromJust . parseW3CDateTime)
- ) -< tree
- blogName <- maybeA (getAttrValue0 "blogName") -< tree
- excerpt <- maybeA ( getChildren
- >>>
- getText
- ) -< tree
- returnA -< TrackBack {
- tbTitle = title
- , tbExcerpt = excerpt
- , tbURL = url
- , tbBlogName = blogName
- , tbTime = time
- }
, mkQueryString
)
where
-import qualified Codec.Binary.UTF8.String as UTF8
-import Control.Arrow
-import Control.Arrow.ArrowList
-import qualified Data.ByteString.Lazy as Lazy (ByteString)
-import qualified Data.ByteString.Lazy.Char8 as L8 hiding (ByteString)
+import Control.Arrow
+import Control.Arrow.ArrowList
+import Data.ByteString (ByteString)
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Char8 as C8
+import qualified Data.ByteString.Lazy as LS
+import qualified Data.ByteString.Unsafe as BS
+import Data.Char
import Data.Monoid.Unicode
import Data.String
-import Magic
-import Network.HTTP.Lucu
-import Network.URI
+import Data.Text (Text)
+import Data.Text.Encoding
+import Magic
+import Network.HTTP.Lucu
+import Network.URI
+import Numeric
import Prelude.Unicode
-import System.IO.Unsafe
+import System.IO.Unsafe
yesOrNo ∷ Bool → String
yesOrNo True = "yes"
trueOrFalse False = "false"
parseYesOrNo ∷ (Eq s, Show s, IsString s, ArrowChoice (⇝)) ⇒ s ⇝ Bool
-parseYesOrNo
- = proc str →
- case str of
- _ | str ≡ "yes" → returnA ⤙ True
- | str ≡ "no" → returnA ⤙ False
- | otherwise → returnA ⤙ error ("Expected yes or no: " ⊕ show str)
+parseYesOrNo = arr f
+ where
+ f "yes" = True
+ f "no" = False
+ f str = error ("Expected yes or no: " ⊕ show str)
-maybeA :: (ArrowList a, ArrowChoice a) => a b c -> a b (Maybe c)
+maybeA ∷ (ArrowList a, ArrowChoice a) ⇒ a b c → a b (Maybe c)
maybeA a = listA a
>>>
- proc xs -> case xs of
- [] -> returnA -< Nothing
- (x:_) -> returnA -< Just x
-
+ proc xs → case xs of
+ [] → returnA ⤙ Nothing
+ (x:_) → returnA ⤙ Just x
-deleteIfEmpty :: (ArrowList a, ArrowChoice a) => a String String
+deleteIfEmpty ∷ (ArrowList a, ArrowChoice a) ⇒ a String String
deleteIfEmpty
- = proc str -> do case str of
- "" -> none -< ()
- _ -> returnA -< str
-
+ = proc str → do case str of
+ "" → none ⤙ ()
+ _ → returnA ⤙ str
-chomp :: String -> String
-chomp = reverse . snd . break (/= '\n') . reverse
+chomp ∷ String → String
+{-# INLINE chomp #-}
+chomp = reverse . snd . break (≢ '\n') . reverse
-
-guessMIMEType :: Lazy.ByteString -> MIMEType
-guessMIMEType = read . unsafePerformIO . magicString magic . L8.unpack
+guessMIMEType ∷ LS.ByteString → MIMEType
+{-# INLINEABLE guessMIMEType #-}
+guessMIMEType = read
+ ∘ unsafePerformIO
+ ∘ flip BS.unsafeUseAsCStringLen (magicCString magic)
+ ∘ BS.concat
+ ∘ LS.toChunks
where
- magic :: Magic
+ magic ∷ Magic
+ {-# NOINLINE magic #-}
magic = unsafePerformIO
- $ do m <- magicOpen [MagicMime]
+ $ do m ← magicOpen [MagicMime]
magicLoadDefault m
return m
-
-isSafeChar :: Char -> Bool
+isSafeChar ∷ Char → Bool
+{-# INLINEABLE isSafeChar #-}
isSafeChar c
- | c == '/' = True
- | isReserved c = False
- | c > ' ' && c <= '~' = True
- | otherwise = False
+ | c ≡ '/' = True
+ | isReserved c = False
+ | c > ' ' ∧ c ≤ '~' = True
+ | otherwise = False
+mkQueryString ∷ [(Text, Text)] → ByteString
+{-# INLINEABLE mkQueryString #-}
+mkQueryString = BS.intercalate (C8.singleton ';') ∘ map encodePair
+ where
+ encodePair ∷ (Text, Text) → ByteString
+ {-# INLINE encodePair #-}
+ encodePair (k, v)
+ = BS.intercalate (C8.singleton '=') [encodeText k, encodeText v]
+
+ encodeText ∷ Text → ByteString
+ {-# INLINE encodeText #-}
+ encodeText = toURLEncoded ∘ encodeUtf8
-mkQueryString :: [(String, String)] -> String
-mkQueryString [] = ""
-mkQueryString ((k, v) : xs) = encode k ++ "=" ++ encode v ++
- if xs == [] then
- ""
- else
- ';' : mkQueryString(xs)
+toURLEncoded ∷ ByteString → ByteString
+{-# INLINEABLE toURLEncoded #-}
+toURLEncoded = C8.concatMap go
where
- encode :: String -> String
- encode = escapeURIString isSafeChar . UTF8.encodeString
\ No newline at end of file
+ go ∷ Char → ByteString
+ {-# INLINE go #-}
+ go c | c ≡ ' ' = C8.singleton '+'
+ | isReserved c = urlEncode c
+ | isUnreserved c = C8.singleton c
+ | otherwise = urlEncode c
+
+ urlEncode ∷ Char → ByteString
+ {-# INLINE urlEncode #-}
+ urlEncode c = C8.pack ('%':toHex (ord c))
+
+ toHex ∷ Int → String
+ {-# INLINE toHex #-}
+ toHex n
+ = case showIntAtBase 16 toChrHex n "" of
+ [] → "00"
+ [c] → ['0', c]
+ cs → cs
+
+ toChrHex ∷ Int → Char
+ {-# INLINE toChrHex #-}
+ toChrHex d
+ | d < 10 = chr (ord '0' + fromIntegral d )
+ | otherwise = chr (ord 'A' + fromIntegral (d-10))
+++ /dev/null
--- FIXME: use time-w3c
-module Rakka.W3CDateTime
- ( formatW3CDateTime
- , parseW3CDateTime
- )
- where
-import Control.Monad
-import Data.Time
-import Prelude hiding (min)
-import Text.ParserCombinators.Parsec
-import Text.Printf
-
-
-formatW3CDateTime :: ZonedTime -> String
-formatW3CDateTime zonedTime
- = formatLocalTime (zonedTimeToLocalTime zonedTime)
- ++
- formatTimeZone (zonedTimeZone zonedTime)
- where
- 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 :: 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` 60
- minute = offset - hour * 60
- in
- show2 hour ++ ":" ++ show2 minute
-
- show2 :: Int -> String
- show2 n | n < 10 = '0' : show n
- | otherwise = show n
-
-
-parseW3CDateTime :: String -> Maybe ZonedTime
-parseW3CDateTime src
- = case parse w3cDateTime "" src of
- Right zt -> Just zt
- Left _ -> Nothing
-
-w3cDateTime :: Parser ZonedTime
-w3cDateTime = do year <- liftM read (count 4 digit)
- mon <- option 1 (char '-' >> liftM read (count 2 digit))
- day <- option 1 (char '-' >> liftM read (count 2 digit))
- (hour, min, sec, offMin)
- <- option (0, 0, 0, 0) time
- eof
-
- let julianDay = fromGregorian year mon day
- timeOfDay = TimeOfDay hour min (fromRational $ toRational sec)
- localTime = LocalTime julianDay timeOfDay
- timeZone = minutesToTimeZone offMin
- zonedTime = ZonedTime localTime timeZone
-
- return zonedTime
- where
- time :: Parser (Int, Int, Double, Int)
- time = do _ <- char 'T'
- hour <- liftM read (count 2 digit)
- _ <- char ':'
- min <- liftM read (count 2 digit)
- sec <- option 0 $ do _ <- char ':'
- secInt <- count 2 digit
- secFrac <- option "" $ do c <- char '.'
- cs <- many1 digit
- return (c:cs)
- return $ read (secInt ++ secFrac)
- offMin <- (char 'Z' >> return 0)
- <|>
- (do sign <- (char '+' >> return 1)
- <|>
- (char '-' >> return (-1))
- h <- liftM read (count 2 digit)
- _ <- char ':'
- m <- liftM read (count 2 digit)
- return $ sign * h * 60 + m)
- return (hour, min, sec, offMin)
\ No newline at end of file
where
import Control.Applicative
import Control.Monad
+import qualified Data.ByteString.Char8 as C8
import Data.Maybe
import Data.Monoid.Unicode
import qualified Data.Text as T
= \ ctx _ -> do BaseURI baseURI <- getSysConf (ctxSysConf ctx)
let uri = baseURI {
uriPath = uriPath baseURI </> "search.html"
- , uriQuery = '?' : mkQueryString [ ("q" , "[UVSET]")
- , ("order", "@mdate NUMD")
- ]
+ , uriQuery = '?' : C8.unpack (mkQueryString [ ("q" , "[UVSET]")
+ , ("order", "@mdate NUMD")
+ ])
}
return $ ExternalLink uri (Just "List all pages")
}
+++ /dev/null
-module Rakka.Wiki.Interpreter.Trackback
- ( interpreters
- )
- where
-
-import Data.Maybe
-import Data.Time
-import Network.HTTP.Lucu.RFC1123DateTime
-import Rakka.Page
-import Rakka.Storage
-import Rakka.SystemConfig
-import Rakka.TrackBack
-import Rakka.Wiki
-import Rakka.Wiki.Interpreter
-
-
-interpreters :: [Interpreter]
-interpreters = [ trackbackURLInterp
- , trackbacksInterp
- ]
-
-
-trackbackURLInterp :: Interpreter
-trackbackURLInterp
- = InlineCommandInterpreter {
- iciName = "trackbackURL"
- , iciInterpret
- = \ ctx _ -> case ctxPageName ctx of
- Nothing
- -> return (Text "No trackbacks for this page.")
- Just name
- -> do BaseURI baseURI <- getSysConf (ctxSysConf ctx)
- let uri = mkAuxiliaryURI baseURI ["trackback"] name
- return $ ExternalLink uri (Just "Trackback URL")
- }
-
-
-trackbacksInterp :: Interpreter
-trackbacksInterp
- = BlockCommandInterpreter {
- bciName = "trackbacks"
- , bciInterpret
- = \ ctx _ ->
- do trackbacks <- case ctxPageName ctx of
- Nothing
- -> return []
- Just name
- -> liftM (fromMaybe [])
- (getAttachment (ctxStorage ctx) name "trackbacks" Nothing)
- items <- mapM mkListItem trackbacks
-
- let divElem = Div [("class", "trackbacks")] [list]
- list = Block (List Bullet items)
-
- return divElem
- }
- where
- mkListItem :: TrackBack -> IO ListItem
- mkListItem tb
- = do zonedTime <- utcToLocalZonedTime (tbTime tb)
-
- let anchor = Just (Inline (ExternalLink (tbURL tb) label))
- label = case (tbTitle tb, tbBlogName tb) of
- (Nothing , Nothing ) -> Nothing
- (Just title, Nothing ) -> Just title
- (Nothing , Just blogName) -> Just blogName
- (Just title, Just blogName) -> Just (title ++ " (" ++ blogName ++ ")")
- date = Just ( Block ( Div [("class", "date")]
- [Inline (Text (formatRFC1123DateTime zonedTime))]
- )
- )
- excerpt = do e <- tbExcerpt tb
- return $ Block $ Paragraph [Text e]
-
- return $ catMaybes [anchor, date, excerpt]
\ No newline at end of file
ys <- (paragraph' <|> return [])
return (Text "\n" : ys)
-- \n があり、その次に \n または
- -- blockSymbols があれば、fail して
- -- 最初の newline を讀んだ所まで卷き
- -- 戻す。
-
- -- FIXME: 本當にそのやうな動作になつ
- -- てゐるか？偶然動いてゐるだけではな
- -- いか？確かにこの實裝でユニットテス
- -- トは通るのだが、私の理解を越えてし
- -- まったやうだ。
+ -- blockSymbols があれば、fail して最
+ -- 初の newline を讀んだ所まで卷き戻
+ -- す。oneOf が一文字消費しているので、
+ -- <|> は右辺を適用せずに try まで戻
+ -- る。
)
<|>
paragraph'
--- /dev/null
+--- !ditz.rubyforge.org,2008-03-06/issue
+title: Allow guests to leave their comments on pages.
+desc: |-
+ Such data should be stored as page attachments.
+ There should be a global flag to disallow comments.
+type: :feature
+component: Rakka
+release:
+reporter: PHO <pho@cielonegro.org>
+status: :unstarted
+disposition:
+creation_time: 2010-03-02 13:03:04.294484 Z
+references: []
+
+id: 0b925fc6286aa2d52ebd379b4c4283b14dfec865
+log_events:
+- - 2010-03-02 13:03:05.766604 Z
+ - PHO <pho@cielonegro.org>
+ - created
+ - ""
+git_branch:
--- /dev/null
+--- !ditz.rubyforge.org,2008-03-06/issue
+title: Rakka is rather bitrotted
+desc: We have to repair it ASAP.
+type: :task
+component: Rakka
+release: "0.1"
+reporter: PHO <pho@cielonegro.org>
+status: :in_progress
+disposition:
+creation_time: 2011-07-29 14:12:39.862597 Z
+references: []
+
+id: 1c6bfe78f0f9ebd241b8650eb62939dc932cd6f0
+log_events:
+- - 2011-07-29 14:12:40.853438 Z
+ - PHO <pho@cielonegro.org>
+ - created
+ - ""
+- - 2011-07-29 14:13:16.762514 Z
+ - PHO <pho@cielonegro.org>
+ - changed status from unstarted to in_progress
+ - I'm working on this...
+git_branch:
--- /dev/null
+--- !ditz.rubyforge.org,2008-03-06/issue
+title: Wouldn't it be cool if Rakka was totally pure-Haskell?
+desc: |-
+ We currently use the following impure packages:
+ - HsHyperEstraier
+ - HsSVN
+ - HsOpenSSL
+ - magic
+type: :task
+component: Rakka
+release:
+reporter: PHO <pho@cielonegro.org>
+status: :unstarted
+disposition:
+creation_time: 2010-03-02 13:28:59.008922 Z
+references: []
+
+id: 227c3bdad879b5f85aae08563b932f99b3f95cec
+log_events:
+- - 2010-03-02 13:29:00.177175 Z
+ - PHO <pho@cielonegro.org>
+ - created
+ - ""
+git_branch:
--- /dev/null
+--- !ditz.rubyforge.org,2008-03-06/issue
+title: Make sure that dumpRepos isn't leaking space.
+desc: See the title.
+type: :task
+component: Rakka
+release: "0.1"
+reporter: PHO <pho@cielonegro.org>
+status: :unstarted
+disposition:
+creation_time: 2010-05-05 15:51:20.513633 Z
+references: []
+
+id: 44d0ce5b9aaba1b8249f4974dba3fc249d416322
+log_events:
+- - 2010-05-05 15:51:23.889811 Z
+ - PHO <pho@cielonegro.org>
+ - created
+ - ""
+git_branch:
--- /dev/null
+--- !ditz.rubyforge.org,2008-03-06/issue
+title: View Page History
+desc: Show a list of patches for one page.
+type: :feature
+component: Rakka
+release:
+reporter: PHO <pho@cielonegro.org>
+status: :unstarted
+disposition:
+creation_time: 2010-03-02 13:43:37.174053 Z
+references: []
+
+id: 5587f7535b16ea0a4765f3b953bd07ab318966af
+log_events:
+- - 2010-03-02 13:43:40.998400 Z
+ - PHO <pho@cielonegro.org>
+ - created
+ - ""
+git_branch:
--- /dev/null
+--- !ditz.rubyforge.org,2008-03-06/issue
+title: Make browsers' Back and Forward buttons usable
+desc: |-
+ We should find a way to make browsers' Back and Forward buttons usable.
+ URI fragments may help us, but how about internal state changes, like modified textarea?
+type: :task
+component: Rakka
+release:
+reporter: PHO <pho@cielonegro.org>
+status: :unstarted
+disposition:
+creation_time: 2010-03-02 12:57:47.325591 Z
+references: []
+
+id: 5731bf94f62b6eaf8af7e1dff0da117a5ca2a0d7
+log_events:
+- - 2010-03-02 12:57:48.765873 Z
+ - PHO <pho@cielonegro.org>
+ - created
+ - ""
+git_branch:
--- /dev/null
+--- !ditz.rubyforge.org,2008-03-06/issue
+title: Write logs into localstatedir
+desc: |-
+ The logger should send logs into localstatedir.
+ File rotation should be up to users.
+type: :feature
+component: Rakka
+release: "0.1"
+reporter: PHO <pho@cielonegro.org>
+status: :unstarted
+disposition:
+creation_time: 2010-03-02 12:48:35.732250 Z
+references: []
+
+id: 6e437d5ba59c9e6e45a171d38a8a3e00dde0daac
+log_events:
+- - 2010-03-02 12:48:36.530186 Z
+ - PHO <pho@cielonegro.org>
+ - created
+ - ""
+git_branch:
--- /dev/null
+--- !ditz.rubyforge.org,2008-03-06/issue
+title: Use W3C File API for file uploading
+desc: "See: http://www.w3.org/TR/FileAPI/"
+type: :task
+component: Rakka
+release: "0.1"
+reporter: PHO <pho@cielonegro.org>
+status: :unstarted
+disposition:
+creation_time: 2011-07-28 13:19:57.240486 Z
+references: []
+
+id: 73be8ef0e6371216aad7134f681140b285daa6d1
+log_events:
+- - 2011-07-28 13:19:58.041198 Z
+ - PHO <pho@cielonegro.org>
+ - created
+ - ""
+git_branch:
--- /dev/null
+--- !ditz.rubyforge.org,2008-03-06/issue
+title: Daemonize by calling forkProcess
+desc: forkProcess should work well on recent GHC. Let's make use of it.
+type: :task
+component: Rakka
+release:
+reporter: PHO <pho@cielonegro.org>
+status: :unstarted
+disposition:
+creation_time: 2011-07-28 10:25:05.111304 Z
+references: []
+
+id: 7a12321e30fd891c30011330b31f825d7d4549f2
+log_events:
+- - 2011-07-28 10:25:06.730757 Z
+ - PHO <pho@cielonegro.org>
+ - created
+ - ""
+git_branch:
--- /dev/null
+--- !ditz.rubyforge.org,2008-03-06/issue
+title: View Source
+desc: Page sources should be available for anyone, to help creating their own pages.
+type: :feature
+component: Rakka
+release:
+reporter: PHO <pho@cielonegro.org>
+status: :unstarted
+disposition:
+creation_time: 2010-03-02 13:41:52.366561 Z
+references: []
+
+id: 7bb656d7ef68651e449d8c66a4fdadd184256039
+log_events:
+- - 2010-03-02 13:41:53.822772 Z
+ - PHO <pho@cielonegro.org>
+ - created
+ - ""
+git_branch:
--- /dev/null
+--- !ditz.rubyforge.org,2008-03-06/issue
+title: Cabalize the test suite
+desc: Cabal now supports integrated unit testing. Make use of it.
+type: :task
+component: Rakka
+release:
+reporter: PHO <pho@cielonegro.org>
+status: :unstarted
+disposition:
+creation_time: 2011-07-28 13:23:38.025610 Z
+references: []
+
+id: 9545180523678d2ab2e32f83ec05abafc291a2a9
+log_events:
+- - 2011-07-28 13:23:39.385643 Z
+ - PHO <pho@cielonegro.org>
+ - created
+ - ""
+git_branch:
--- /dev/null
+--- !ditz.rubyforge.org,2008-03-06/issue
+title: Implement account manipulation
+desc: systemConfig has a missing feature to create or drop user accounts.
+type: :feature
+component: Rakka
+release: "0.1"
+reporter: PHO <pho@cielonegro.org>
+status: :unstarted
+disposition:
+creation_time: 2010-03-02 12:45:47.445331 Z
+references: []
+
+id: a4c1df68e9bc332385b9c9e425738e59a029fb69
+log_events:
+- - 2010-03-02 12:45:51.399236 Z
+ - PHO <pho@cielonegro.org>
+ - created
+ - ""
+git_branch:
--- /dev/null
+--- !ditz.rubyforge.org,2008-03-06/issue
+title: config/baseURI should not be in the SVN repository.
+desc: |-
+ When it's in the repos, we can't easilly setup a new instance of Rakka.
+ It should be passed to the executable as a program argument.
+type: :task
+component: Rakka
+release: "0.1"
+reporter: PHO <pho@cielonegro.org>
+status: :unstarted
+disposition:
+creation_time: 2011-07-28 10:29:09.012108 Z
+references: []
+
+id: b48298a8f36cd22b796c114a3ebfb3cb21bb4c0e
+log_events:
+- - 2011-07-28 10:29:11.998502 Z
+ - PHO <pho@cielonegro.org>
+ - created
+ - ""
+git_branch:
--- /dev/null
+--- !ditz.rubyforge.org,2008-03-06/issue
+title: Page templates
+desc: There should be a way to load templates at the beginning of page creation.
+type: :feature
+component: Rakka
+release:
+reporter: PHO <pho@cielonegro.org>
+status: :unstarted
+disposition:
+creation_time: 2010-03-02 13:13:26.600190 Z
+references: []
+
+id: d411223c56973e94b7c7754eaf81039a03bb0b4c
+log_events:
+- - 2010-03-02 13:13:31.370116 Z
+ - PHO <pho@cielonegro.org>
+ - created
+ - ""
+git_branch:
--- /dev/null
+--- !ditz.rubyforge.org,2008-03-06/issue
+title: "There should be a way to escape from data: scheme to http: scheme."
+desc: |-
+ When we open an image page in Rakka, we can't easilly get out of html+data: to just an image.
+ We can't easily save it to the disk.
+ We can't easily scale it (especially when the image is large).
+type: :task
+component: Rakka
+release:
+reporter: PHO <pho@cielonegro.org>
+status: :unstarted
+disposition:
+creation_time: 2010-03-02 13:25:59.810753 Z
+references: []
+
+id: d96e069d2394c7a1de663af67888efe61f938c89
+log_events:
+- - 2010-03-02 13:26:01.442864 Z
+ - PHO <pho@cielonegro.org>
+ - created
+ - ""
+git_branch:
--- /dev/null
+--- !ditz.rubyforge.org,2008-03-06/issue
+title: IP address blacklisting
+desc: There should be a way to disallow some people to make any changes.
+type: :feature
+component: Rakka
+release:
+reporter: PHO <pho@cielonegro.org>
+status: :unstarted
+disposition:
+creation_time: 2010-03-02 13:06:23.750179 Z
+references: []
+
+id: fb986d0c30569e0026e9d14f887823a372d4f6c5
+log_events:
+- - 2010-03-02 13:10:13.576295 Z
+ - PHO <pho@cielonegro.org>
+ - created
+ - |-
+ Shouldn't Lucu have a feature like this:
+ - Disallow POST, DELETE, PUT by 1.2.3.4/24
+ - Disallow All by 10.11.12.13/30
+
+ Such banlist shall be configured dynamically by Lucu resources...
+git_branch:
--- /dev/null
+--- !ditz.rubyforge.org,2008-03-06/project
+name: Rakka
+version: "0.5"
+components:
+- !ditz.rubyforge.org,2008-03-06/component
+ name: Rakka
+releases:
+- !ditz.rubyforge.org,2008-03-06/release
+ name: "0.1"
+ status: :unreleased
+ release_time:
+ log_events:
+ - - 2010-03-02 12:42:25.957028 Z
+ - PHO <pho@cielonegro.org>
+ - created
+ - This will be the first public release without complete documentations and features.
SUDO ?= sudo
AUTOCONF ?= autoconf
HLINT ?= hlint
+HPC ?= hpc
+DITZ ?= ditz
CONFIGURE_ARGS ?= --disable-optimization
SETUP_FILE := $(wildcard Setup.*hs)
CABAL_FILE := $(wildcard *.cabal)
+PKG_NAME := $(CABAL_FILE:.cabal=)
ifeq ($(shell ls configure.ac 2>/dev/null),configure.ac)
AUTOCONF_AC_FILE := configure.ac
build: setup-config build-hook
./Setup build
+ $(RM_RF) *.tix
build-hook:
$(GHC) --make Setup
clean: clean-hook
- $(RM_RF) dist Setup *.o *.hi .setup-config *.buildinfo
+ $(RM_RF) dist Setup *.o *.hi .setup-config *.buildinfo *.tix .hpc
$(FIND) . -name '*~' -exec rm -f {} \;
clean-hook:
./Setup sdist
test: build
+ $(RM_RF) dist/test
./Setup test
+ if ls *.tix >/dev/null 2>&1; then \
+ $(HPC) sum --output="merged.tix" --union --exclude=Main *.tix; \
+ $(HPC) markup --destdir="dist/hpc" --fun-entry-count "merged.tix"; \
+ fi
+
+ditz:
+ $(DITZ) html dist/ditz
+
+fixme:
+ @$(FIND) . \
+ \( -name 'dist' -or -name '.git' -or -name '_darcs' \) -prune \
+ -or \
+ \( -name '*.c' -or -name '*.h' -or \
+ -name '*.hs' -or -name '*.lhs' -or \
+ -name '*.hsc' -or -name '*.cabal' \) \
+ -exec egrep -i '(fixme|thinkme)' {} \+ \
+ || echo 'No FIXME or THINKME found.'
lint:
- $(HLINT) . --report \
- --ignore="Use string literal" \
- --ignore="Use concatMap"
-
-.PHONY: build build-hook setup-config setup-config-hook run clean clean-hook install doc sdist test lint
+ $(HLINT) . --report
+
+push: doc ditz
+ if [ -d "_darcs" ]; then \
+ darcs push; \
+ elif [ -d ".git" ]; then \
+ git push --all && git push --tags; \
+ fi
+ if [ -d "dist/doc" ]; then \
+ rsync -av --delete \
+ dist/doc/html/$(PKG_NAME)/ \
+ www@nem.cielonegro.org:static.cielonegro.org/htdocs/doc/$(PKG_NAME); \
+ fi
+ rsync -av --delete \
+ dist/ditz/ \
+ www@nem.cielonegro.org:static.cielonegro.org/htdocs/ditz/$(PKG_NAME)
+
+.PHONY: build build-hook setup-config setup-config-hook run clean clean-hook install doc sdist test lint push
text-indent: 0;
}
-.sideBar .recentUpdates p,
-.sideBar .trackbacks p {
+.sideBar .recentUpdates p {
font-size: 90%;
}
text-indent: 0;
}
-.sideBar .recentUpdates p,
-.sideBar .trackbacks p {
+.sideBar .recentUpdates p {
font-size: 90%;
}
-moz-border-radius: 10px;
}
-.sideBar .recentUpdates li, .sideBar .trackbacks li {
+.sideBar .recentUpdates li {
background-color: #e0e0e0;
}
projects / Rakka.git / commitdiff