-
Notifications
You must be signed in to change notification settings - Fork 0
/
Wiki.hs
222 lines (193 loc) · 10.4 KB
/
Wiki.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
{-# LANGUAGE Rank2Types,OverloadedStrings #-}
module Wiki (procWiki, depsWiki, alwaysWiki) where
import System.FilePath
import Data.List
import Data.Char
import Data.Monoid
import Data.Maybe
import Data.Functor
import Control.Applicative
import System.FilePath
import System.Directory
import qualified Data.ByteString.Lazy.Char8 as B
import Safe
import BSUtils
import Common
import HtmlStyle
import LatexStyle
import WikiData
{-
import Dependency
alwaysUpdate text = mappend (if "!!sitemap!!" `subListOf` lc then Always "Sitemap" else UpToDate)
(if "!!recentchanges!!" `subListOf` lc then Always "RecentChanges" else UpToDate)
where lc = map toLower text
-}
alwaysWiki wi page = (B.pack "!!sitemap!!") `subStringCI` (smContent page) ||
(B.pack "!!recentchanges!!") `subStringCI` (smContent page)
depsWiki :: WikiInfo -> PageInfo -> [PageInfo]
depsWiki wi wiki = mapMaybe (flip lookupPage (sitemap wi)) $
mapMaybe unLecture $ map parseSpecialLine $
filter isSpecialLine $
map stripWhitespace $
B.split '\n' $
smContent wiki
where unLecture (Right (SpecialLecture name)) = Just (PageName (B.unpack name))
unLecture _ = Nothing
procWiki :: FileProcessor
procWiki wiki = do
let htmlFile = pageOutput wiki "html"
let pdfFile = pageOutput wiki "pdf"
let content = smContent wiki
--depRes <- mappend (alwaysUpdate content) `fmap` needUpdate htmlFile [wiki]
--let up2date = isUpToDate depRes
--liftIO $ showState (pagename wiki) depRes
wi <- getWi
parsed <- parse wi $ map stripWhitespace $ B.split '\n' content
return [
([htmlFile], writeHtmlPage htmlFile wiki (pagename wiki) parsed)
-- ([pdfFile], writeLatexPage wiki (pagename wiki) parsed)
]
stripWhitespace :: B.ByteString -> B.ByteString
stripWhitespace t | B.null t = t
| B.last t == ' ' = stripWhitespace (B.init t)
| otherwise = t
parse :: WikiInfo -> [B.ByteString] -> FileProducer Document
parse wi [] = return []
parse wi (l:r) | B.null l = parse wi r
| hl > 0 = (Header hl header :) <$> parse wi r
| isSpecialLine l = (:) <$> parseSpecial wi l <*> parse wi r
| isHLine l = (HLine :) <$> parse wi r
| isListLine l = parseList wi (l:r)
| isPreLine l = parsePre wi (l:r)
| isParaLine l = parsePara wi (l:r)
| otherwise = error ("Unknown line "++ B.unpack l)
where (hl, header) = parseHeader l
parseHeader line | B.singleton '=' `encloses` line = add $ parseHeader $ takeout (B.singleton '=') line
| otherwise = (0, line)
where add (x,y) = (x+1,y)
isListLine = B.isPrefixOf (B.singleton '*')
isPreLine = B.isPrefixOf (B.singleton ' ')
isSpecialLine = (B.pack "!!" `encloses`)
isHLine l = B.length l >= 4 && myAll (`elem` ("=-_"::String)) l
isParaLine l = not (isListLine l) &&
not (isPreLine l) &&
not (B.null l) &&
not (fst (parseHeader l) > 0) &&
not (isSpecialLine l) &&
not (isHLine l)
parseList wi = parseLines wi isListLine ItemList (parseInline wi . B.tail)
parsePre wi = parseLines wi isPreLine (PreFormat . B.unlines) B.tail
parsePara wi = parseLines wi isParaLine (Paragraph . concatMap (++[Text (B.singleton ' ')])) (parseInline wi)
parseLines :: forall t . WikiInfo
-> (B.ByteString -> Bool)
-> ([t] -> DocElement)
-> (B.ByteString -> t)
-> [B.ByteString]
-> FileProducer Document
parseLines wi cond markup mapF lines | null list = error "Did not find what I should parse"
| otherwise = (markup (map mapF list) :) <$> parse wi rest
where (list,rest) = span cond lines
parseInline :: WikiInfo -> B.ByteString -> InlineText
parseInline wi t | B.null t = []
| isBlockedLink = Text skword : parseInline wi skrest
| isCamelCase word = LinkElem (mkLink wi word) : parseInline wi wrest
| isBracketLink = LinkElem (mkLink wi link) : parseInline wi (B.tail lrest)
| isBlockedBracketLink = Text (B.concat ["[",blink,"]"]) : parseInline wi (B.tail blrest)
| isWebLink = LinkElem (PlainLink wlink wlink) :
parseInline wi wlrest
| not (B.null space) = Text space : parseInline wi srest
| not (B.null word) = Text word : parseInline wi wrest
| isBrokenLink = Text (B.take 1 t) : parseInline wi (B.tail t)
| isBrokenBlock = Text (B.take 1 t) : parseInline wi (B.tail t)
| otherwise = error $ "Unhandled case in parseInline: "++ B.unpack t
where (link, lrest) = B.span (not . (== ']')) (B.tail t)
(blink, blrest) = B.span (not . (== ']')) (B.tail (B.tail t))
(word, wrest) = B.span isAlphaNum t
(skword, skrest) = B.span isAlphaNum (B.tail t) -- skip !
(space, srest) = B.span isNormalNonWord t
(wlink, wlrest) = B.span isWebLinkChar t
isNormalNonWord c = not (isAlphaNum c) && not (c `elem` ("[!"::String))
isBlockedLink = B.head t == '!' && isCamelCase skword
isBrokenBlock = B.singleton '!' `B.isPrefixOf` t && not isBlockedLink
isBrokenLink = B.singleton '[' `B.isPrefixOf` t && not isBracketLink
isBlockedBracketLink
= "![" `B.isPrefixOf` t && not (B.null blrest) && isValidPagename blink
isBracketLink = B.singleton '[' `B.isPrefixOf`t && not (B.null lrest) && isValidPagename link
isWebLink = (B.pack "http://") `B.isPrefixOf` t
isWebLinkChar c = isAlphaNum c || c `elem` (":/_.-~?=#"::String) -- more to add?
isCamelCase t = not (B.null t) && isUpper w && myAny isUpper ord && myAny isLower ord && myAll isAlphaNum t && myAll isAscii t
where (w,ord) = (B.head t, B.tail t)
mkPageLink wi page = WikiLink page (B.pack (pagename page))
mkLink :: WikiInfo -> B.ByteString -> Link
mkLink wi a = case lookupPage (PageName (B.unpack a)) (sitemap wi) of
Just page -> WikiLink page a
Nothing -> NewLink (B.unpack a)
isValidPagename = myAll (\c -> isAlphaNum c || c `elem` ("_-/"::String) )
data Special = SpecialHello | SpecialSiteMap | SpecialRecentChanges
| SpecialLecture B.ByteString | SpecialLectureSearch
parseSpecialLine :: B.ByteString -> Either B.ByteString Special
parseSpecialLine l | cmd == B.pack "hello"
= return SpecialHello
| cmd == B.pack "sitemap"
= return SpecialSiteMap
| cmd == B.pack "recentchanges"
= return SpecialRecentChanges
| cmd == B.pack "lecture"
= case args of
[file] -> return (SpecialLecture file)
_ -> Left $ B.pack "Invalid argument to \"lecture\": " `B.append` B.unwords args
| cmd == B.pack "lecturesearch"
= return SpecialLectureSearch
| otherwise
= Left $ B.pack "Unknown Command \"" `B.append` cmd `B.append` B.pack "\""
where
words = B.words $ takeout (B.pack "!!") l
cmd = case words of
[] -> B.pack ""
c:_ -> B.map toLower c
args = tail words
parseSpecial :: WikiInfo -> B.ByteString -> FileProducer DocElement
parseSpecial wi l = case parseSpecialLine l of
Right SpecialHello ->
return $ Paragraph [Text (B.pack "Hello World")]
Right SpecialSiteMap ->
return $ ItemList $ map (\page -> [LinkElem (mkPageLink wi page), Text (dotIfNotNull (B.pack (pageType page)))]) $ sort $ sitemap wi
Right SpecialRecentChanges ->
return $ RCElem (map (parseRC wi) (recentChanges wi))
Right (SpecialLecture file) ->
genLiElem wi file
Right SpecialLectureSearch ->
return LectureSearch
Left err ->
return $ Paragraph [Text err]
genLiElem wi file = case lookupPage (PageName (B.unpack file)) (sitemap wi) of
Just page -> do
let metaDataFile = pageOutput page "metadata"
ex <- liftIO $ doesFileExist metaDataFile
mbMd <- if ex then do
metaDataText <- liftIO $ readFile metaDataFile
(metaDataText == metaDataText) `seq` return ()
case readMay metaDataText of
Just md -> return $ Just md
Nothing -> liftIO $ removeFile metaDataFile >> return Nothing
else return Nothing
return $ LIElem $ LectureInfo page mbMd
Nothing -> return $ Paragraph [Text (B.pack "Lecture file \"" `B.append` file `B.append` B.pack "\" not found.")]
parseRC wi (RawLogEntry hash auth date paths raw_msg) = LogEntry hash auth date links msg (Just githublink)
where msg = parseInline wi raw_msg
filtered_paths = filter (\f -> all (\d -> not (d `isPrefixOf` f)) (ignoredDirs wi)) paths
links = flip map filtered_paths $ \path ->
case lookupPage (PageName (dropExtensions path)) (sitemap wi) of
Just page -> mkPageLink wi page
Nothing -> NewLink (dropExtensions path)
githublink = PlainLink (B.pack "https://github.com/nomeata/mitschriebwiki/commit/" `B.append` hash) (B.pack "GitHub commit")
encloses sub str = sub `B.isPrefixOf` str && sub `myIsSuffixOf` str && B.length str > 2 * B.length sub
--encloses sub str = sub `isPrefixOf` str && sub `isSuffixOf` str && length str > 2 * length sub
takeout sub str = B.drop (B.length sub) $ B.take (B.length str - B.length sub) $ str
--takeout sub = (drop (length sub)).reverse.(drop (length sub)).reverse
(\/) pre post str = pre ++ str ++ post
-- Missing ByteString functions
sub `myIsSuffixOf` str = B.length str >= B.length sub && sub == (B.drop (B.length str - B.length sub) str)
myAll p s = B.foldr (\c b -> p c && b) True s
myAny p s = B.foldr (\c b -> p c || b) False s
dotIfNotNull s = if B.null s then s else "." `B.append` s