~alcinnz/Hearth

ref: 3871d4b028cb9d1cf35050a711ad6d6de8a3c4f5 Hearth/app/Main.hs -rw-r--r-- 2.6 KiB
3871d4b0 — Adrian Cochrane Add reading-list support! 11 months ago 
                                                                                
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
{-# LANGUAGE OverloadedStrings, TemplateHaskell #-}
module Main where

import Network.Wai.Handler.Warp
import Network.Wai
import Network.HTTP.Types
import Network.Wai.Parse

import Data.Text.Lazy (fromStrict)
import qualified Data.Text as Txt
import qualified Data.Text.Lazy.Encoding as LTxt
import Data.Text.Encoding (decodeUtf8)
import Data.ByteString (ByteString, stripPrefix)
import Data.Maybe (fromMaybe)

import Data.FileEmbed
import Data.Char (isSpace)
import Data.Time.Format.ISO8601 (iso8601ParseM)
import Network.URI (parseURIReference)
import Data.Maybe (mapMaybe)

import Data.Aeson (decodeFileStrict, encodeFile, Value(..))
import qualified System.Directory as Dir

import Hearth (renderPage, handleForm, markAsRead, Link, utf8)

main :: IO ()
main = do
  putStrLn "http://127.0.0.1:2019/"
  runEnv 2019 servePage

dbFile :: FilePath
dbFile = "hearth.json"

servePage :: Application
servePage req respond = do
    hasDB <- Dir.doesFileExist dbFile
    db <- if hasDB then decodeFileStrict dbFile else return Nothing
    let db' = fromMaybe Null db
    case requestMethod req of
        "GET" | Just dest <- stripPrefix "/read/" $ rawPathInfo req -> do
                encodeFile dbFile $ markAsRead dest db'
                respond $ responseLBS status301 [(hLocation, dest)] ""
            | Just resp <- renderPage (rawPathInfo req) (queryString req)
                (headerAcceptLang req) history db' ->
            respond $ responseLBS status200 [] $ LTxt.encodeUtf8 $ fromStrict resp
        "POST" -> do
            (query, _) <- parseRequestBodyEx defaultParseRequestBodyOptions lbsBackEnd req
            (redirect, dbNew) <- handleForm (rawPathInfo req) query db'
            encodeFile dbFile dbNew
            respond $ responseLBS status301 [(hLocation, redirect)] ""
        _ -> respond $ responseLBS status404 [] "Page not found!"

headerAcceptLang :: Request -> [Txt.Text]
headerAcceptLang = parseAcceptLang . lookup hAcceptLanguage . requestHeaders
parseAcceptLang :: Maybe ByteString -> [Txt.Text]
parseAcceptLang = map dropParam . Txt.splitOn "," . decodeUtf8 . fromMaybe "en"
    where dropParam = Txt.takeWhile (/= ';')

history :: [Link]
history = mapMaybe parseLine $ lines $
        utf8 $(makeRelativeToProject "history.tsv" >>= embedFile)
    where
        stripL = dropWhile isSpace
        parseLine line | '#':_ <- stripL line = Nothing
            | [] <- stripL line = Nothing
            | Just url' <- parseURIReference url,
                Just date' <- iso8601ParseM date = Just (title, url', date')
            | otherwise = Nothing
          where
            (url, titleDate) = break (== '\t') line
            (title, date) = break (== '\t') titleDate