gdritter repos profile-site / 2db1436
Basic showing, no CSS Getty Ritter 10 years ago
4 changed file(s) with 127 addition(s) and 28 deletion(s). Collapse all Expand all
+22
-14
Main.hs less more
33
44 module Main where
55
6 import Control.Monad (forM_)
7 import Data.HashMap (toList)
8 -- import qualified Storage as S
9 -- import qualified Templates as T
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)
11 import qualified Storage as S
12 import qualified Templates as T
1013 import Web.Spock.Safe
1114
1215 {- /
2326
2427 -}
2528
26 projectR :: Path '[Text]
29 projectR :: Path '[String]
2730 projectR = "project" <//> var
2831
2932 loginR :: Path '[]
3235 editR :: Path '[]
3336 editR = "edit"
3437
35 editProjectR :: Path '[Text]
38 editProjectR :: Path '[String]
3639 editProjectR = "edit" <//> "project" <//> var
3740
3841 main :: IO ()
3942 main = runSpock 8080 $ spockT id $ do
40 get Root $ do
41 projs <- S.getProjects
42 text "foo"
43 get root $ do
44 projects <- liftIO S.getAllProjects
45 lazyBytes (renderBS $ T.projectList projects)
4346 get projectR $ \ p -> do
44 text "whoo"
45 post Root $ do
47 project <- liftIO (S.getProject p)
48 text (T.pack $ show project)
49 {-
50 post root $ do
4651 fs <- files
4752 forM_ (toList fs) $ \ (k, v) -> do
48 liftIO $ putStrLn $ "name" ++ show k
49 liftIO $ putStrLn $ "uf_name" ++ show (uf_name v)
50 liftIO $ putStrLn $ "uf_tempLocation" ++ show (uf_tempLocation v)
53 liftIO $ do
54 putStrLn $ "name" ++ show k
55 putStrLn $ "uf_name" ++ show (uf_name v)
56 putStrLn $ "uf_contentType" ++ show (uf_contentType v)
57 putStrLn $ "uf_tempLocation" ++ show (uf_tempLocation v)
5158 text "blah"
59 -}
+58
-13
Storage.hs less more
11 {-# LANGUAGE OverloadedStrings #-}
2 {-# LANGUAGE FlexibleInstances #-}
3 {-# LANGUAGE DeriveGeneric #-}
4 {-# LANGUAGE DeriveAnyClass #-}
5 {-# LANGUAGE ViewPatterns #-}
6 {-# LANGUAGE ScopedTypeVariables #-}
27
38 module Storage where
49
10 import Control.Exception (catch)
511 import Data.Aeson
12 import Data.ByteString.Lazy (ByteString)
613 import Data.FileStore
7 import Data.FileStore.Git
14 import Data.Maybe (catMaybes)
15 import Data.Monoid ((<>))
16 import Data.String (IsString)
17 import Data.Text (Text)
18 --import Data.UUID.V4
19 import GHC.Generics(Generic)
20
21 (</>) :: (IsString m, Monoid m) => m -> m -> m
22 x </> y = x <> "/" <> y
23
24 data ImageType
25 = ItPNG
26 | ItJPG
27 | ItGIF
28 deriving (Eq, Show)
829
930 data Project = Project
1031 { projectSlug :: Text
1132 , projectName :: Text
1233 , projectDescr :: Text
13 , projectImgs :: [Text]
14 } deriving (Eq, Show)
34 , projectImgs :: [String]
35 } deriving (Eq, Show, Generic, FromJSON, ToJSON)
1536
16 instance Contents (Maybe Project) where
17 fromByteString = decode
18 toByteString (Just x) = encode x
19 toByteString Nothing = error "should not happen"
37 recover :: forall a. IO (Maybe a) -> IO (Maybe a)
38 recover action = action `catch` go
39 where go :: FileStoreError -> IO (Maybe a)
40 go _ = return Nothing
41
42 fromValue :: FromJSON b => a -> (b -> a) -> ByteString -> a
43 fromValue def f v = case decode v of
44 Nothing -> def
45 Just x -> f x
2046
2147 portfolioStore :: FileStore
2248 portfolioStore = gitFileStore "portfolio-data"
2349
24 getProjectByName :: String -> IO (Maybe Project)
25 getProjectByName name = retrieve (name <> ".json") portfolioStore Nothing
50 getProjectNames :: IO [String]
51 getProjectNames = fmap (fromValue [] id)
52 (retrieve portfolioStore "projects.json" Nothing)
2653
27 getImage :: String -> IO (Maybe ByteString)
28 getImage name = retrieve ("images" </> name) portfolioStore Nothing
54 getAllProjects :: IO [Project]
55 getAllProjects = getProjectNames >>= (fmap catMaybes . mapM getProject)
2956
30 newImage :: UploadedFile -> ()
31 newImage = undefined
57 getProject :: String -> IO (Maybe Project)
58 getProject name =
59 fmap (fromValue Nothing Just)
60 (retrieve portfolioStore (name <> ".json") Nothing)
61
62 getImage :: String -> IO ByteString
63 getImage name = retrieve portfolioStore ("images" </> name) Nothing
64
65 {-
66 imageType :: String -> ImageType
67 imageType "image/gif" = ItGIF
68 imageType "image/jpeg" = ItJPG
69 imageType _ = ItPNG
70
71 newImage :: UploadedFile -> IO ()
72 newImage uf = do
73 let typ = imageType (uf_contentType uf)
74 name <- nextRandom
75 return ()
76 -}
+37
-0
Templates.hs less more
1 {-# LANGUAGE OverloadedStrings #-}
2 {-# LANGUAGE RecordWildCards #-}
3
4 module Templates where
5
6 import Data.Monoid ((<>))
7 import Data.Text (Text, pack)
8 import Lucid
9 import qualified Storage as S
10
11 footer :: Html ()
12 footer = "© Empress Cortana 2015"
13
14 page :: Html () -> Html () -> Html ()
15 page name contents = html_ $ do
16 head_ $ do
17 title_ name
18 body_ $ do
19 div_ [id_ "header"] $ h1_ name
20 div_ [id_ "main"] $ contents
21 div_ [id_ "footer"] $ footer
22
23 projectList :: [S.Project] -> Html ()
24 projectList = page "empress cortana // portfolio" . mapM_ shortProj
25
26 imgUrl :: String -> Text
27 imgUrl s = pack ("imgs/" <> s)
28
29 projUrl :: Text -> Text
30 projUrl s = "project/" <> s
31
32 shortProj :: S.Project -> Html ()
33 shortProj (S.Project { .. }) = div_ [class_ "project"] $ do
34 div_ [id_ "name"] $ a_ [href_ (projUrl projectSlug)] $ toHtml projectName
35 case projectImgs of
36 (img:_) -> div_ [id_ "tile"] $ img_ [src_ (imgUrl img)]
37 [] -> return ()
+10
-1
cortana-portfolio.cabal less more
1313 Main-Is: Main.hs
1414 Default-Language: Haskell2010
1515 GHC-Options: -Wall
16 Build-Depends: base >= 4 && < 5, Spock, containers
16 Build-Depends: base >= 4 && < 5,
17 Spock,
18 unordered-containers,
19 bytestring,
20 text,
21 aeson,
22 transformers,
23 uuid,
24 filestore,
25 lucid
1726
1827 Source-Repository head
1928 Type: git