_{MsgNoComment}
28 | $else
29 |
_{MsgHaveCommentsOn}
30 | ^{entryListWidget "" entryList}
31 | |]
32 |
--------------------------------------------------------------------------------
/src/Handler/Common.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE NoImplicitPrelude #-}
2 | {-# LANGUAGE OverloadedStrings #-}
3 | {-# LANGUAGE TemplateHaskell #-}
4 | {-# LANGUAGE MultiParamTypeClasses #-}
5 | {-# LANGUAGE TypeFamilies #-}
6 | -- | Common handler functions.
7 | module Handler.Common where
8 |
9 | import Data.FileEmbed (embedFile)
10 | import Import
11 |
12 | -- These handlers embed files in the executable at compile time to avoid a
13 | -- runtime dependency, and for efficiency.
14 |
15 | getFaviconR :: Handler TypedContent
16 | getFaviconR = do cacheSeconds $ 60 * 60 * 24 * 30 -- cache for a month
17 | return $ TypedContent "image/x-icon"
18 | $ toContent $(embedFile "config/favicon.ico")
19 |
20 | getRobotsR :: Handler TypedContent
21 | getRobotsR = return $ TypedContent typePlain
22 | $ toContent $(embedFile "config/robots.txt")
23 |
--------------------------------------------------------------------------------
/src/Handler/Download.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE QuasiQuotes #-}
2 | {-# LANGUAGE OverloadedStrings #-}
3 | {-# LANGUAGE NoImplicitPrelude #-}
4 | {-# LANGUAGE TemplateHaskell #-}
5 | module Handler.Download where
6 |
7 | {-import Import
8 |
9 | downloadWidget :: EntryId -> Widget
10 | downloadWidget entryId = toWidget
11 | [julius|
12 | let route = "@{DownloadR entryId}";
13 | function downloadFile() {
14 | fetch('route')
15 | .then(response => response.blob())
16 | .then(blob => {
17 | const url = window.URL.createObjectURL(blob);
18 | const a = document.createElement('a');
19 | a.href = url;
20 | a.download = "example.pdf"; // Change filename if necessary
21 | document.body.appendChild(a);
22 | a.click();
23 | a.remove();
24 | })
25 | .catch(error => console.error('Download error:', error));
26 | }
27 | $('download a').click(downloadFile);
28 | |]-}
--------------------------------------------------------------------------------
/src/Handler/EditCategory.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE OverloadedStrings #-}
2 | {-# LANGUAGE QuasiQuotes #-}
3 | {-# LANGUAGE NoImplicitPrelude #-}
4 | module Handler.EditCategory where
5 |
6 | import Import
7 | import Yesod.Form.Bootstrap3
8 | import Parse.Parser(parse,texToHtmlSimple)
9 | import Handler.Parse(userTemporaryDirectory)
10 |
11 | data CategoryInput = CategoryInput
12 | { categoryTitle :: Text
13 | }
14 |
15 | categoryForm :: Maybe CategoryInput -> Form CategoryInput
16 | categoryForm mInput = renderBootstrap3 BootstrapBasicForm $ CategoryInput
17 | <$> areq titleField titleSettings (categoryTitle <$> mInput)
18 | where
19 | titleField = check validateTitle textField
20 | maxTitleLength = 256
21 | validateTitle title = if length title <= maxTitleLength then Right title else Left (MsgTooLongByCharCount (length title - maxTitleLength))
22 | titleSettings = FieldSettings
23 | { fsLabel = ""
24 | , fsTooltip = Nothing
25 | , fsId = Nothing
26 | , fsName = Just "title"
27 | , fsAttrs = [("autofocus", ""), ("class", "form-control"), ("placeholder", "keyword")]
28 | }
29 |
30 | postNewCategoryR :: Handler Value
31 | postNewCategoryR = do
32 | userId <- requireAuthId
33 | ((result, _), _) <- runFormPost $ categoryForm Nothing
34 | case result of
35 | FormSuccess categoryInput -> do
36 | let title = categoryTitle categoryInput
37 | userDir<-userTemporaryDirectory
38 | titleHtml <-liftIO $ parse Nothing userDir texToHtmlSimple title
39 | currentTime <- liftIO getCurrentTime
40 |
41 | categoryId <- runDB $ insert $ Entry
42 | { entryUserId=userId
43 | , entryType=Category
44 | , entryStatus=Publish
45 | , entryInserted=currentTime
46 | , entryUpdated=currentTime
47 | , entryTitle=title
48 | , entryPreamble=Nothing
49 | , entryFormat=Format "tex"
50 | , entryBody=Nothing
51 | , entryCitation=Nothing
52 | , entryTitleHtml=titleHtml
53 | , entryBodyHtml=""
54 | , entryFeatured=False
55 | }
56 |
57 | return $ object ["id" .= categoryId, "title" .= titleHtml]
58 | FormFailure msgs -> return $ object ["errors" .= msgs]
59 | _ -> return $ object ["error" .= ("Invalid form"::Text)]
60 |
61 | postEditCategoryR :: EntryId -> Handler Value
62 | postEditCategoryR entryId = do
63 | --(userId,user) <- requireAuthPair
64 | ((result, _), _) <- runFormPost $ categoryForm Nothing
65 | case result of
66 | FormSuccess categoryInput -> do
67 | let title = categoryTitle categoryInput
68 | userDir<-userTemporaryDirectory
69 | titleHtml <-liftIO $ parse Nothing userDir texToHtmlSimple title
70 | currentTime <- liftIO getCurrentTime
71 | runDB $ update entryId [EntryTitle=.title, EntryTitleHtml=.titleHtml, EntryUpdated=.currentTime]
72 |
73 | return $ object ["id" .= entryId, "title" .= titleHtml]
74 | FormFailure msgs -> return $ object ["errors" .= msgs]
75 | _ -> return $ object ["error" .= ("Invalid form"::Text)]
76 |
77 | deleteEditCategoryR :: EntryId -> Handler Value
78 | deleteEditCategoryR entryId = do
79 | runDB $ delete entryId
80 | return $ object ["deleted" .= True]
--------------------------------------------------------------------------------
/src/Handler/EditEntrySubscription.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE QuasiQuotes #-}
2 | {-# LANGUAGE OverloadedStrings #-}
3 | {-# LANGUAGE NoImplicitPrelude #-}
4 | module Handler.EditEntrySubscription where
5 |
6 | import Import
7 | import Yesod.Form.Bootstrap3 (BootstrapFormLayout (..), renderBootstrap3)
8 | import Handler.Subscriptions (getSubscriptions)
9 |
10 | getEditEntrySubscriptionR :: EntrySubscriptionId -> Handler Html
11 | getEditEntrySubscriptionR subscriptionId = do
12 | subscription <- runDB $ get404 subscriptionId
13 | verificationKey <- lookupGetParam "key"
14 | if entrySubscriptionKey subscription == verificationKey && isJust (entrySubscriptionKey subscription)
15 | then do
16 | if entrySubscriptionVerified subscription
17 | then do
18 | getSubscriptions $ entrySubscriptionEmail subscription
19 | else do
20 | runDB $ update subscriptionId [EntrySubscriptionVerified =. True]
21 |
22 | setMessageI MsgSubscriptionVerified
23 | getSubscriptions $ entrySubscriptionEmail subscription
24 | else do
25 | permissionDeniedI MsgPermissionDenied
26 |
27 |
28 | postEditEntrySubscriptionR :: EntrySubscriptionId -> Handler Html
29 | postEditEntrySubscriptionR subscriptionId = do
30 | ((result, _), _) <- runFormPost unsubscribeForm
31 | case result of
32 | FormSuccess verificationKey -> do
33 | subscription <- runDB $ get404 subscriptionId
34 | if entrySubscriptionKey subscription == verificationKey && isJust (entrySubscriptionKey subscription)
35 | then do
36 | runDB $ delete subscriptionId
37 | setMessageI MsgSubscriptionDeleted
38 | getSubscriptions $ entrySubscriptionEmail subscription
39 | else do
40 | permissionDeniedI MsgPermissionDenied
41 |
42 | FormFailure errors -> do
43 | setMessage [shamlet|
44 | $forall error <- errors
45 |
#{error}
46 | |]
47 | redirectUltDest HomeR
48 | _ -> do
49 | setMessageI MsgFormMissing
50 | redirectUltDest HomeR
51 |
52 |
53 | unsubscribeForm :: Form (Maybe Text)
54 | unsubscribeForm = renderBootstrap3 BootstrapBasicForm $ aopt hiddenField keySettings Nothing
55 | where
56 | keySettings = FieldSettings {
57 | fsLabel = "",
58 | fsTooltip = Nothing,
59 | fsId = Nothing,
60 | fsName = Just "key",
61 | fsAttrs = [("autofocus", ""), ("placeholder", "Key"), ("class", "form-control")]
62 | }
63 |
--------------------------------------------------------------------------------
/src/Handler/EditFeedback.hs:
--------------------------------------------------------------------------------
1 | module Handler.EditFeedback where
2 |
3 |
4 |
--------------------------------------------------------------------------------
/src/Handler/EditUserAbout.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE OverloadedStrings #-}
2 | {-# LANGUAGE QuasiQuotes #-}
3 | {-# LANGUAGE NoImplicitPrelude #-}
4 | module Handler.EditUserAbout where
5 |
6 | import Import
7 | import Yesod.Form.Bootstrap3
8 | import Handler.Parse(editorWidget)
9 | import Handler.EditUserEntry(EntryInput(..),entry2Html)
10 |
11 | entryInputForm:: Maybe EntryInput -> Html -> MForm Handler (FormResult EntryInput, Widget)
12 | entryInputForm mEntryInput=renderBootstrap3 BootstrapBasicForm $ EntryInput
13 | <$> areq textField titleSetting (inputTitle <$> mEntryInput)
14 | <*> areq (selectFieldList inputFormats) formatSettings (inputFormat <$> mEntryInput)
15 | <*> aopt textareaField preambleSettings (inputPreamble <$> mEntryInput)
16 | <*> aopt textareaField editorSettings (inputBody <$> mEntryInput)
17 | <*> aopt textareaField citationSettings (inputCitation <$> mEntryInput) where
18 | inputFormats = [(MsgMarkdownWithLaTeX, Format "md"), (MsgPureLaTeX, Format "tex")]
19 | formatSettings = FieldSettings
20 | { fsLabel = SomeMessage MsgSelfIntroduction
21 | , fsTooltip = Nothing
22 | , fsId = Nothing
23 | , fsName = Just "format"
24 | , fsAttrs =[("class", "input-sm form-control format-selector")]}
25 | editorSettings = FieldSettings
26 | { fsLabel = ""
27 | , fsTooltip = Nothing
28 | , fsId = Nothing
29 | , fsName = Just "content"
30 | , fsAttrs =[ ("class", "editor form-control"), ("placeholder", "Your content goes here. Press [Ctrl + Enter] to preview.")]}
31 | preambleSettings = FieldSettings
32 | { fsLabel = ""
33 | , fsTooltip = Nothing
34 | , fsId = Nothing
35 | , fsName = Just "preamble"
36 | , fsAttrs =[("class", "hidden")]}
37 | citationSettings = FieldSettings
38 | { fsLabel = ""
39 | , fsTooltip = Nothing
40 | , fsId = Nothing
41 | , fsName = Just "citation"
42 | , fsAttrs =[("class", "hidden")]}
43 | titleSetting=FieldSettings
44 | { fsLabel = ""
45 | , fsTooltip = Nothing
46 | , fsId = Nothing
47 | , fsName = Just "title"
48 | , fsAttrs =[ ("class", "form-control hidden"), ("placeholder", "your title")]}
49 |
50 |
51 | getEditUserAboutR :: Handler Html
52 | getEditUserAboutR = do
53 | (Entity userId user) <- requireAuth
54 | msgRender <- getMessageRender
55 | mEntry<-runDB $ selectFirst [EntryType==.UserPage, EntryUserId==.userId] [Desc EntryInserted]
56 | formatParam <- lookupGetParam "format"
57 | let format = case (formatParam,mEntry) of
58 | (Just "tex",_) -> Format "tex"
59 | (Just "md",_) -> Format "md"
60 | (_,Just entry) -> entryFormat $ entityVal entry
61 | _ -> userDefaultFormat user
62 |
63 | (entryWidget, entryEnctype) <- case entityVal <$> mEntry of
64 | Just entry-> do
65 | generateFormPost $ entryInputForm $ Just $ EntryInput (entryTitle entry) format (entryPreamble entry) (entryBody entry) (entryCitation entry)
66 | Nothing-> do
67 | generateFormPost $ entryInputForm $ Just $ EntryInput "About" format (userDefaultPreamble user) (Just (Textarea $ msgRender MsgNoAbout)) (userDefaultCitation user)
68 | defaultLayout $ do
69 | setTitle "About"
70 | [whamlet|
71 |
About
72 |