gdritter repos inf-dict / 536de91
Added site itself, in more or less working shape Getty Ritter 8 years ago
5 changed file(s) with 394 addition(s) and 0 deletion(s). Collapse all Expand all
+61
-0
src/Main.hs less more
1 module Main where
2
3 import Control.Monad.IO.Class
4 import Database.SQLite.Simple (Connection, open)
5 import Data.Monoid ((<>))
6 import Data.Text (pack)
7 import Network.HTTP.Types.Status (status404)
8 import Network.Wai.Middleware.Static (staticPolicy, hasPrefix)
9 import System.Environment (lookupEnv)
10 import Web.Spock
11
12 import Render
13 import Types
14
15 respondWith :: [Entry] -> ActionCtxT ctx IO ()
16 respondWith es = do
17 pref <- preferredFormat
18 case pref of
19 PrefJSON -> json es
20 _ -> html (rPage (rEntries es))
21
22 db :: DB a -> ActionCtxT Connection IO a
23 db mote = do
24 conn <- getContext
25 liftIO (mote conn)
26
27 main :: IO ()
28 main = do
29 dbLoc <- maybe "test.db" id `fmap` lookupEnv "DB_LOC"
30 port <- maybe 8080 read `fmap` lookupEnv "PORT"
31 conn <- open dbLoc
32 runSpock port $ spockT id $ prehook (return conn) $ do
33 middleware $ staticPolicy (mempty <> hasPrefix "static")
34 get root $ do
35 html (rPage "welcome to the dictionary yo")
36 get "add" $ do
37 ls <- db allLanguages
38 html (rPage (rAdd ls))
39 get "search" $ do
40 html (rPage rSearch)
41 get "word" $ do
42 es <- db getAllWords
43 respondWith es
44 post "word" $ do
45 ps <- params
46 case paramsToEntry ps of
47 Nothing -> setStatus status404
48 Just e -> do
49 i <- db (addWord e)
50 redirect (pack ("/word/" ++ show i))
51 get ("word" <//> var) $ \ w -> do
52 eM <- db (getWordById w)
53 case eM of
54 Just e -> respondWith [e]
55 Nothing -> setStatus status404
56 get ("word" <//> "search" <//> var) $ \ t -> do
57 db (searchAll t) >>= respondWith
58 get ("word" <//> "search" <//> "by-word" <//> var) $ \ t -> do
59 db (searchWord t) >>= respondWith
60 get ("word" <//> "search" <//> "by-meaning" <//> var) $ \ t -> do
61 db (searchMeaning t) >>= respondWith
+73
-0
src/Render.hs less more
1 module Render where
2
3 import Control.Monad (when)
4 import Data.Text (Text, pack)
5 import Data.Text.Lazy (toStrict)
6 import Lucid
7
8 import Types
9
10 rPage :: Html () -> Text
11 rPage content = toStrict $ renderText $ doctypehtml_ $ do
12 head_ $ do
13 meta_ [ httpEquiv_ "Content-Type"
14 , content_ "text/html; encoding=utf8;"
15 ]
16 link_ [ href_ "/static/main.css"
17 , rel_ "stylesheet"
18 , type_ "text/css"
19 ]
20 title_ "infinite negative dictionary"
21 body_ $ do
22 div_ [ class_ "header" ] $ do
23 h1_ "Infinite Negative Dictionary"
24 div_ [ class_ "menu" ] $ do
25 menu
26 div_ [ class_ "main" ] $ do
27 content
28 div_ [ class_ "footer" ] $ do
29 "[what do I need here? copyright?]"
30
31 menu :: Html ()
32 menu = ul_ $ do
33 li_ $ a_ [ href_ "/" ] "index"
34 li_ $ a_ [ href_ "/word" ] "browse"
35 li_ $ a_ [ href_ "/add" ] "add"
36 li_ $ a_ [ href_ "/search" ] "search"
37
38 rEntries :: [Entry] -> Html ()
39 rEntries = mapM_ rEntry
40
41 rEntry :: Entry -> Html ()
42 rEntry e = div_ [ class_ "entry" ] $ do
43 div_ [ class_ "word" ] $ toHtml (eWord e)
44 div_ [ class_ "translit" ] $ toHtml (eTranslit e)
45 div_ [ class_ "meaning" ] $ toHtml (eMeaning e)
46 when (eNotes e /= "") $
47 div_ [ class_ "notes" ] $ toHtml (eNotes e)
48
49 rSearch :: Html ()
50 rSearch = form_ [ name_ "search" ] $ do
51 input_ [ type_ "text", name_ "query" ]
52
53 rAdd :: [Language] -> Html ()
54 rAdd ls = form_ [ name_ "add", action_ "/word", method_ "POST" ] $ do
55 div_ $ do
56 label_ "Language: "
57 select_ [ name_ "lang" ] $ sequence_
58 [ option_ [ value_ (pack (show i)) ] $ toHtml n
59 | Language { langId = i, langName = n } <- ls
60 ]
61 div_ $ do
62 label_ "Word: "
63 input_ [ type_ "text", name_ "word" ]
64 div_ $ do
65 label_ "Transliteration: "
66 input_ [ type_ "text", name_ "translit" ]
67 div_ $ do
68 label_ "Meaning: "
69 textarea_ [ rows_ "4", cols_ "100", name_ "meaning" ] ""
70 div_ $ do
71 label_ "Notes: "
72 textarea_ [ rows_ "4", cols_ "100", name_ "notes" ] ""
73 div_ $ input_ [ type_ "submit" ]
+141
-0
src/Types.hs less more
1 module Types where
2
3 import Database.SQLite.Simple
4 import Data.Aeson
5 import Data.Monoid ((<>))
6 import Data.Text (Text, unpack)
7 import Control.Error (headMay)
8 import Text.Read (readMaybe)
9
10 type DB a = Connection -> IO a
11
12 -- | Language
13
14 data Language = Language
15 { langId :: Integer
16 , langName :: Text
17 } deriving (Eq, Show)
18
19 instance FromRow Language where
20 fromRow = Language <$> field <*> field
21
22 instance ToRow Language where
23 toRow l = toRow (Only (langName l))
24
25 instance ToJSON Language where
26 toJSON l = object [ "id" .= langId l
27 , "name" .= langName l
28 ]
29
30 instance FromJSON Language where
31 parseJSON = withObject "Language object" $ \ o ->
32 Language <$> o .: "id"
33 <*> o .: "name"
34
35 allLanguages :: DB [Language]
36 allLanguages conn =
37 query_ conn "SELECT id, name FROM languages"
38
39 -- | Entry
40
41 data Entry = Entry
42 { eID :: Integer
43 , eWord :: Text
44 , eTranslit :: Text
45 , eMeaning :: Text
46 , eNotes :: Text
47 , eLanguage :: Language
48 } deriving (Eq, Show)
49
50 instance FromRow Entry where
51 fromRow = Entry <$> field
52 <*> field
53 <*> field
54 <*> field
55 <*> field
56 <*> (Language <$> field <*> field)
57
58 instance ToRow Entry where
59 toRow e = toRow ( eWord e
60 , eTranslit e
61 , eMeaning e
62 , eNotes e
63 , langId (eLanguage e)
64 )
65
66 instance ToJSON Entry where
67 toJSON e = object [ "id" .= eID e
68 , "word" .= eWord e
69 , "translit" .= eTranslit e
70 , "meaning" .= eMeaning e
71 , "notes" .= eNotes e
72 , "language" .= eLanguage e
73 ]
74
75 instance FromJSON Entry where
76 parseJSON = withObject "Word object" $ \ o ->
77 Entry <$> o .: "id"
78 <*> o .: "word"
79 <*> o .: "translit"
80 <*> o .: "meaning"
81 <*> o .: "notes"
82 <*> o .: "language"
83
84 paramsToEntry :: [(Text,Text)] -> Maybe Entry
85 paramsToEntry ps = Entry <$> pure 0
86 <*> lookup "word" ps
87 <*> lookup "translit" ps
88 <*> lookup "meaning" ps
89 <*> lookup "notes" ps
90 <*> (flip Language "???" <$> langNum)
91 where langNum = lookup "lang" ps >>= (readMaybe . unpack)
92
93 --
94
95 addWord :: Entry -> DB Integer
96 addWord entry conn = do
97 let q = "INSERT INTO words (word, trans, meaning, notes, language) \
98 \ VALUES (?,?,?,?,?)"
99 execute conn q entry
100 fromIntegral <$> lastInsertRowId conn
101
102 getWordById :: Integer -> DB (Maybe Entry)
103 getWordById i conn = do
104 let q = "SELECT w.id, w.word, w.trans, w.meaning, w.notes, l.id, l.name \
105 \ FROM words w, languages l \
106 \ WHERE w.id = ? AND w.language = l.id"
107 headMay <$> query conn q (Only i)
108
109 getAllWords :: DB [Entry]
110 getAllWords conn = do
111 let q = "SELECT w.id, w.word, w.trans, w.meaning, w.notes, l.id, l.name \
112 \ FROM words w, languages l \
113 \ WHERE w.language = l.id"
114 query_ conn q
115
116 searchText :: Text -> Text
117 searchText t = "%" <> t <> "%"
118
119 searchWord :: Text -> DB [Entry]
120 searchWord t conn = do
121 let q = "SELECT w.id, w.word, w.trans, w.meaning, w.notes, l.id, l.name \
122 \ FROM words w, languages l \
123 \ WHERE w.language = l.id AND \
124 \ (w.word LIKE ? OR w.trans LIKE ?)"
125 query conn q (searchText t, searchText t)
126
127 searchMeaning :: Text -> DB [Entry]
128 searchMeaning t conn = do
129 let q = "SELECT w.id, w.word, w.trans, w.meaning, w.notes, l.id, l.name \
130 \ FROM words w, languages l \
131 \ WHERE w.language = l.id AND \
132 \ (w.meaning LIKE ? OR w.notes LIKE ?)"
133 query conn q (searchText t, searchText t)
134
135 searchAll :: Text -> DB [Entry]
136 searchAll t conn = do
137 let q = "SELECT w.id, w.word, w.trans, w.meaning, w.notes, l.id, l.name \
138 \ FROM words w, languages l \
139 \ WHERE w.language = l.id AND \
140 \ (w.word LIKE ? OR w.trans LIKE ? OR w.meaning LIKE ? OR w.notes LIKE ?)"
141 query conn q (searchText t, searchText t, searchText t, searchText t)
+119
-0
static/main.css less more
1 @font-face {
2 font-family: trinako;
3 src: url("/static/trinako_sans.otf");
4 }
5
6 body {
7 background-color: #eee;
8 font-family: "Arial", "Helvetica", sans-serif;
9 }
10
11 .header {
12 text-align: center;
13 letter-spacing: 0.2em;
14 }
15
16 .menu {
17 text-align: center;
18 }
19
20 .menu li {
21 display: inline;
22 list-style-type: none;
23 padding-left: 20px;
24 padding-right: 40px;
25 }
26
27 .main {
28 border-top-style: solid;
29 border-top-width: 1px;
30 border-bottom-style: solid;
31 border-bottom-width: 1px;
32 width: 50%;
33 background-color: #f7f7f7;
34 padding: 40px;
35 margin-left: auto;
36 margin-right: auto;
37 margin-bottom: 20px;
38 }
39
40 .word {
41 font-family: trinako;
42 float: left;
43 margin-left: 2em;
44 font-weight: bold;
45 margin-bottom: 10px;
46 }
47
48 .translit {
49 float: right;
50 padding-right: 50%;
51 font-style: italic;
52 margin-bottom: 10px;
53 }
54
55 .meaning {
56 clear: left;
57 padding-top: 10px;
58 padding-left: 40px;
59 padding-right: 40px;
60 border-top-style: solid;
61 border-top-width: 1px;
62 border-top-color: #aaa;
63 }
64
65 .notes {
66 font-style: italic;
67 }
68
69 .entry {
70 background-color: #fff;
71 clear: left;
72 margin-top: 15px;
73 margin-bottom: 15px;
74 padding-left: 20px;
75 padding-right: 20px;
76 padding-top: 10px;
77 padding-bottom: 10px;
78 }
79
80 .footer {
81 text-align: center;
82 width: 400px;
83 margin-left: auto;
84 margin-right: auto;
85 }
86
87 form {
88 width: 80%;
89 margin: 0 auto;
90 }
91
92 label, input {
93 display: inline-block;
94 }
95
96 label {
97 clear: right;
98 width: 30%;
99 text-align: right;
100 margin-bottom: 10px;
101 }
102
103 label + input {
104 width: 30%;
105 margin: 0 30% 0 4%;
106 }
107
108 input + input {
109 float: right;
110 }
111
112 select {
113 width: 50%;
114 margin-left: 4%;
115 }
116
117 textarea {
118 float: right;
119 }⏎
static/trinako_sans.otf less more
Binary diff not shown