-
Notifications
You must be signed in to change notification settings - Fork 9
/
Main.hs
237 lines (222 loc) · 10.2 KB
/
Main.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
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Main where
import Config.Schema.Load
import Control.Monad (unless, void, (<=<))
import Control.Monad.Extra (ifM)
import Control.Monad.IO.Class (liftIO)
import qualified Data.ByteString.Char8 as BS
import qualified Data.ByteString.Lazy as BSL
import qualified Data.Map.Strict as M
import Data.Maybe (fromMaybe, isJust)
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import Data.Time
import Lib
import Lib.Github (validateAuthToken)
import Lucid (renderText)
import Network.HTTP.Client
import Network.HTTP.Client.TLS (newTlsManager)
import Network.HTTP.Types.Status (badRequest400)
import Network.Wai.Middleware.RequestLogger
import Network.Wai.Middleware.Static
import Network.Wai.Parse
import System.Directory
( createDirectoryIfMissing,
doesFileExist,
findExecutable,
getHomeDirectory,
)
import System.Exit (ExitCode (..))
import System.FilePath ((</>))
import Web.Scotty
main :: IO ()
main = do
userHomeDir <- getHomeDirectory
let fullLocalDir = userHomeDir </> ".fermatslastmargin"
fullUserDir = fullLocalDir </> "localuser"
fullStaticDir = fullLocalDir </> "pageimages"
fullFriendsDir = fullLocalDir </> "friends"
-- create config dirs if missing
mapM_ (createDirectoryIfMissing True) [fullUserDir, fullStaticDir, fullFriendsDir]
-- check for pdftocairo in $PATH, or crap out and die
ifM (isJust <$> findExecutable "pdftocairo") (pure ()) (error "cannot find pdftocairo in $PATH")
-- create HTTP manager cause we gonna need it?
mgmt <- newTlsManager
-- load all papers and notes
userState <- readState fullUserDir
-- load github username and oauth token
let configFile = fullLocalDir </> "config"
haveConfigFile <- doesFileExist configFile
unless haveConfigFile (writeFile configFile "username: \"\"\noauth: \"\"")
gc <- loadValueFromFile githubSpec configFile
friendState <- readFriendState fullFriendsDir
friendPapers <- readFriendView fullFriendsDir
scotty 3000 $ do
middleware logStdoutDev
middleware $ staticPolicy (noDots >-> addBase "static")
middleware $ staticPolicy (noDots >-> addBase (fullLocalDir </> "pageimages"))
-- this function always matches, then checks for empty gitconfig
-- can't possibly be fast to check for EVERY SINGLE REQUEST, what's easier/simpler ?
get (function $ const $ Just []) $ do
-- is this really a good idea?
gc' <- liftIO $ loadValueFromFile githubSpec configFile
unless ("" == username gc || ("" == oauth gc')) next
html . renderText $ pageTemplate "Set GitHub Configuration Values" authform
get "/" $ do
nowTime <- liftIO getCurrentTime
papers <- liftIO $ readPaper fullUserDir
html . renderText $
pageTemplate "Papers" $ do
flmheader -- Render header
papersearch -- Render paper search form
notespush -- Render "Push Notes" button
friendspull -- Render "Pull Friends Notes" button
paperfilterForm -- Render paper filter form
paperstable papers -- Render papers table
papersadd (utctDay nowTime) -- Render add paper form
get "/filter" $ do
(searchTerm :: T.Text) <- param "pattern"
nowTime <- liftIO getCurrentTime
papers <- liftIO $ filterpapers searchTerm <$> readPaper fullUserDir
html . renderText $
pageTemplate "Papers" $ do
flmheader -- Render header
papersearch -- Render paper search form
notespush -- Render "Push Notes" button
friendspull -- Render "Pull Friends Notes" button
paperfilterForm -- Render paper filter form
paperstable papers -- Render papers table
papersadd (utctDay nowTime) -- Render add paper form
post "/setauth" $ do
-- this isn't real secure
uname <- param "username" -- don't shadow username, it's a record accessor for GithubConfig
mAuthToken <- validateAuthToken . T.strip <$> param "oauth"
case mAuthToken of
Nothing -> raiseStatus badRequest400 "Invalid github authentication token"
Just authToken -> do
-- https://github.com/glguy/config-schema/issues/2
liftIO $ writeFile configFile ("username: \"" <> uname <> "\"\noauth: \"" <> T.unpack authToken <> "\"")
void . liftIO $ loadValueFromFile githubSpec configFile
html "Your credentials have been saved"
redirect "/newuser"
post "/paper" $ do
ps <- params
fs <- files
let fs' = [(fieldName, BS.unpack (fileName fi), fileContent fi) | (fieldName, fi) <- fs]
let maybePaper = mbP ps
case maybePaper of
Just thePaper -> do
let cleanPaper = sanitizePaper thePaper
liftIO $ do
writeState fullUserDir $ M.insert (uid cleanPaper) cleanPaper userState
_ <- commitEverything fullUserDir -- just wrote paper.json, now stuff it into git, don't even check it!
let paperDir = fullStaticDir </> T.unpack (uid cleanPaper)
createDirectoryIfMissing True paperDir -- gotta have this
BS.writeFile (paperDir </> "paper.pdf") (BSL.toStrict $ third $ head fs') -- head scares me, gonna die at some point
_ <- renderPageImages paperDir -- should really check/report failure here
putStrLn "should have worked now!"
redirect "/"
Nothing -> raise "something's broken"
post "/updatepdf" $ do
puid <- param "uidtoupdate"
fs <- files
let fs' = [(fieldName, BS.unpack (fileName fi), fileContent fi) | (fieldName, fi) <- fs]
_ <- liftIO $ do
let paperDir = fullStaticDir </> TL.unpack puid
createDirectoryIfMissing True paperDir -- gotta have this
BS.writeFile (paperDir </> "paper.pdf") (BSL.toStrict $ third $ head fs') -- head scares me, gonna die at some point
renderPageImages paperDir
redirect $ "/index.html?uid=" <> puid
post "/annotate" $ do
(jd :: Annotation) <- jsonData
mbPaper <- liftIO $ M.lookup (paperuid jd) <$> readState fullUserDir
final <- case mbPaper of
Nothing -> raise "That Paper does not exist"
Just p -> liftIO $ writePaper fullUserDir $ p {notes = upsertAnnotation jd (notes p)}
_ <- liftIO $ commitEverything fullUserDir
json final
get "/getannotate" $ do
pagenum <- param "pagenum"
puid <- param "paperuid"
ps <- params
mbPaper <- liftIO $ M.lookup puid <$> readState fullUserDir
-- point free code below replaces a big pile of pattern matches on Maybe!
let mbFriendnote =
maybeGetAnnotation pagenum . notes -- that friend's paper have any notes for this page?
<=< M.lookup puid -- does that friend have this paper?
<=< flip M.lookup friendState . TL.toStrict -- does that friend exist?
<=< lookup "viewfriend"
$ ps -- is the user trying to view notes from a friend?
friendnote = fromMaybe (Annotation "" pagenum puid) mbFriendnote
final <- case mbPaper of
Nothing -> raise "That Paper does not exist"
Just p -> pure $ fromMaybe (Annotation "Press Enter to edit this note" pagenum puid) (maybeGetAnnotation pagenum (notes p)) -- ugh!
json [final, friendnote] -- return an array of localuser note, and selected friend note. There must be a better way, argh
get "/friends" $ do
puid <- param "paperuid"
json $ M.findWithDefault [] puid friendPapers
get "/gitpush" $ do
(exitCode, _) <- liftIO $ pushEverything fullUserDir
case exitCode of
ExitSuccess -> redirect "/"
_ -> html "Failed to push to github"
get "/gitpull" $ do
liftIO $ getFriendRepos (username gc) (oauth gc) fullFriendsDir mgmt
redirect "/" -- should really report problems someday
get "/crossref" $ do
(terms :: T.Text) <- param "searchterms"
-- https://github.com/CrossRef/rest-api-doc#api-overview
-- wget "https://api.crossref.org/works?query=room+at+the+bottom"
req <- parseRequest $ T.unpack ("http://api.crossref.org/works?query=" <> terms)
response <- liftIO $ httpLbs req mgmt
let wrapper = fromMaybe emptyWrapper (decodeSR $ responseBody response)
foundpapers = converter <$> (items . message) wrapper
html . renderText $ pageTemplate "Search Results" (foundpaperstable foundpapers)
post "/newpaper" $ do
newPapers :: [Paper] <- jsonData
liftIO $ do
let cleanPapers = sanitizePaper <$> newPapers
print cleanPapers
userState' <- readState fullUserDir
print userState'
let newState = addFoundPapers userState cleanPapers
print newState
writeState fullUserDir newState
redirect "/"
get "/newuser" $ do
-- create the repo on github
createRes <- liftIO $ loadValueFromFile githubSpec configFile >>= createDR . T.unpack . oauth
-- clone the repo from github into fullUserDir
case createRes of
Left e -> html $ "There's a problem: " <> TL.pack (show e)
Right r -> do
_ <- liftIO $ cloneRepo fullUserDir (oauthedremote . unstupid $ (snd . pnRepo) r)
redirect "/"
where
oauthedremote = swizzle (username gc) (oauth gc)
get "/editmetadata" $ do
(puid :: T.Text) <- param "uidtoupdate"
mbPaper <- liftIO $ M.lookup puid <$> readState fullUserDir
case mbPaper of
Nothing -> html "That Paper does not exist"
Just p -> html . renderText $ pageTemplate "Edit metadata" (paperedit p)
post "/editmetadata" $ do
(updatedpaper :: Paper) <- jsonData
liftIO $ print ("it did not sh*t itself" <> show updatedpaper)
mbPaper <- liftIO $ M.lookup (uid updatedpaper) <$> readState fullUserDir
case mbPaper of
Nothing -> do
liftIO $ putStrLn "could not find the paper"
html "That Paper does not exist"
Just p -> do
void . liftIO $
writePaper fullUserDir $
p
{ uid = uid updatedpaper,
author = author updatedpaper,
published = published updatedpaper,
notes = notes p -- don't modify the notes, copy from the previous Paper value
}
liftIO $ putStrLn "paper written successfully"
redirect "/"