Commit master - profile-site

Working HTML; needs edit capability Getty Ritter 9 years ago

3 changed file(s) with 62 addition(s) and 15 deletion(s). Collapse all Expand all

+20

-8

Main.hs less more

3	3
4	4	module Main where
5	5
6		import Control.Monad.IO.Class (liftIO)
7		import Data.Text (Text)
8		import qualified Data.Text as T
9		import Data.HashMap.Strict (toList)
10		import ~~Lucid (renderBS~~)
	6	import Control.Monad.IO.Class (MonadIO, liftIO)
	7	import Lucid (Html, renderBS)
11	8	import qualified Storage as S
12	9	import qualified Templates as T
13	10	import Web.Spock.Safe

32	29	loginR :: Path '[]
33	30	loginR = "login"
34	31
	32	imageR :: Path '[String]
	33	imageR = "imgs" <//> var
	34
35	35	editR :: Path '[]
36	36	editR = "edit"
37	37
38	38	editProjectR :: Path '[String]
39	39	editProjectR = "edit" <//> "project" <//> var
40	40
	41	lucid :: MonadIO m => Html () -> ActionT m a
	42	lucid = lazyBytes . renderBS
	43
41	44	main :: IO ()
42	45	main = runSpock 8080 $ spockT id $ do
43	46	get root $ do
44	47	projects <- liftIO S.getAllProjects
45		l~~azyBytes (renderBS $~~ T.projectList projects)
	48	lucid (T.projectList projects)
46	49	get projectR $ \ p -> do
47		project <- liftIO (S.getProject p)
48		text (T.pack $ show project)
	50	Just project <- liftIO (S.getProject p)
	51	lucid (T.project project)
	52	get loginR $ do
	53	lucid T.loginPage
	54	get imageR $ \ i -> do
	55	setHeader "Content-Type" (S.getType i)
	56	d <- liftIO (S.getImage i)
	57	lazyBytes d
	58	get "css" $ do
	59	setHeader "Content-Type" "text/css"
	60	liftIO S.getCSS >>= lazyBytes
49	61	{-
50	62	post root $ do
51	63	fs <- files

+16

-3

Storage.hs less more

1	1	{-# LANGUAGE OverloadedStrings #-}
2	2	{-# LANGUAGE FlexibleInstances #-}
3	3	{-# LANGUAGE DeriveGeneric #-}
4		{-# LANGUAGE DeriveAnyClass #-}
5	4	{-# LANGUAGE ViewPatterns #-}
6	5	{-# LANGUAGE ScopedTypeVariables #-}
7	6

11	10	import Data.Aeson
12	11	import Data.ByteString.Lazy (ByteString)
13	12	import Data.FileStore
	13	import Data.List (isSuffixOf)
14	14	import Data.Maybe (catMaybes)
15		import Data.Monoid ((<>))
	15	import Data.Monoid (Monoid, (<>))
16	16	import Data.String (IsString)
17	17	import Data.Text (Text)
18	18	--import Data.UUID.V4

32	32	, projectName :: Text
33	33	, projectDescr :: Text
34	34	, projectImgs :: [String]
35		} deriving (Eq, Show, Generic~~, FromJSON, ToJSON~~)
	35	} deriving (Eq, Show, Generic)
	36
	37	instance FromJSON Project where
	38	instance ToJSON Project where
36	39
37	40	recover :: forall a. IO (Maybe a) -> IO (Maybe a)
38	41	recover action = action `catch` go

62	65	getImage :: String -> IO ByteString
63	66	getImage name = retrieve portfolioStore ("images" </> name) Nothing
64	67
	68	getType :: String -> Text
	69	getType s
	70	\| ".png" `isSuffixOf` s = "image/png"
	71	\| ".jpg" `isSuffixOf` s = "image/jpeg"
	72	\| ".gif" `isSuffixOf` s = "image/gif"
	73	\| otherwise = error "unrecognized image type requested"
	74
	75	getCSS :: IO ByteString
	76	getCSS = retrieve portfolioStore ("css") Nothing
	77
65	78	{-
66	79	imageType :: String -> ImageType
67	80	imageType "image/gif" = ItGIF

+26

-4

Templates.hs less more

3	3
4	4	module Templates where
5	5
	6	import Control.Monad (forM_)
	7	import Data.Char (toLower)
6	8	import Data.Monoid ((<>))
7	9	import Data.Text (Text, pack)
	10	import qualified Data.Text as T
8	11	import Lucid
9	12	import qualified Storage as S
10	13
11	14	footer :: Html ()
12		footer = "~~© Empress Cortana 2015~~"
	15	footer = "copyright 2015 Empress Cortana"
13	16
14	17	page :: Html () -> Html () -> Html ()
15	18	page name contents = html_ $ do
16	19	head_ $ do
17	20	title_ name
	21	link_ [rel_ "stylesheet", type_ "text/css", href_ "/css"]
18	22	body_ $ do
19	23	div_ [id_ "header"] $ h1_ name
20	24	div_ [id_ "main"] $ contents
21	25	div_ [id_ "footer"] $ footer
22	26
	27	title :: Text -> Html ()
	28	title t = toHtml ("empress cortana // " <> T.map toLower t)
	29
23	30	projectList :: [S.Project] -> Html ()
24		projectList = page ~~"empress cortana // portfolio"~~ . mapM_ shortProj
	31	projectList = page (title "portfolio") . mapM_ shortProj
	32
	33	project :: S.Project -> Html ()
	34	project p = page (title (S.projectName p)) (fullProj p)
	35
	36	loginPage :: Html ()
	37	loginPage = page (title "login") $ do
	38	form_ [name_ "login", action_ "/login"] $ do
	39	input_ [type_ "password", name_ "password"]
	40	input_ [type_ "submit", value_ "login"]
25	41
26	42	imgUrl :: String -> Text
27		imgUrl s = pack ("imgs/" <> s)
	43	imgUrl s = pack ("/imgs/" <> s)
28	44
29	45	projUrl :: Text -> Text
30		projUrl s = "project/" <> s
	46	projUrl s = "/project/" <> s
31	47
32	48	shortProj :: S.Project -> Html ()
33	49	shortProj (S.Project { .. }) = div_ [class_ "project"] $ do

35	51	case projectImgs of
36	52	(img:_) -> div_ [id_ "tile"] $ img_ [src_ (imgUrl img)]
37	53	[] -> return ()
	54
	55	fullProj :: S.Project -> Html ()
	56	fullProj (S.Project { .. }) = div_ [class_ "project"] $ do
	57	div_ [id_ "descr"] $ toHtml projectDescr
	58	forM_ projectImgs $ \img ->
	59	div_ [id_ "tile"] $ img_ [src_ (imgUrl img)]