Add other stuff

diff --git a/Main.hs b/Main.hs
index 92935c8be3d445e4ce4f8d3d89c38b4bc4123400..7aabc89cdd771cf58b283a57495df3edcd92e07e 100644 (file)
--- a/Main.hs
+++ b/Main.hs
@@ -4,10 +4,15 @@ module Main where
 import Web.Scotty
 import qualified Data.Text.Lazy as T
 import qualified Data.Text.Lazy.IO as T
 import Web.Scotty
 import qualified Data.Text.Lazy as T
 import qualified Data.Text.Lazy.IO as T

+import Data.List
+import Data.Time
+import Data.Maybe
+import Data.Ord

 import Control.Monad.IO.Class
 import Control.Monad
 import qualified Text.MMark as M
 import qualified Text.MMark.Extension.Common as M
 import Control.Monad.IO.Class
 import Control.Monad
 import qualified Text.MMark as M
 import qualified Text.MMark.Extension.Common as M

+import Text.Casing

 import Lucid
 import Lucid.Base
 import System.Directory
 import Lucid
 import Lucid.Base
 import System.Directory


@@ -19,18 +24,23 @@ main = scotty 3000 $ do
   get "/style.css" $ file "style.css"
 
   get "/create" $ html $ renderText $ html_ $ do
   get "/style.css" $ file "style.css"
 
   get "/create" $ html $ renderText $ html_ $ do

-    head_ style
-    body_ $ with form_ [action_ "create", method_ "post"] $ do
-      input_ [name_ "title", type_ "text"]
-      with textarea_ [name_ "body", placeholder_ "body"] ""
+    head_ $ do
+      title_ "Create"
+      style
+    body_ $ do
+      h1_ "Create a new post"
+      with form_ [action_ "create", method_ "post"] $ do
+        input_ [name_ "title", type_ "text", placeholder_ "Title"]
+        br_ []
+        with textarea_ [name_ "body", placeholder_ "# Your markdown here"] ""
+        br_ []

         input_ [type_ "submit"]
 
   post "/create" $ do
         input_ [type_ "submit"]
 
   post "/create" $ do

-    title <- param "title"
-    body <- param "body"
-    let fp = "posts" </> T.unpack title <.> "md"
-    liftIO $ T.writeFile fp body
-    redirect ("post/" <> title)
+    t <- param "title"
+    b <- param "body"
+    p <- liftIO $ save b t
+    redirect ("post/" <> title p)

 
   post "/login" $ do
     username <- param "username"
 
   post "/login" $ do
     username <- param "username"


@@ -40,33 +50,75 @@ main = scotty 3000 $ do
       else redirect "/create"
 
   get "/" $ do
       else redirect "/create"
 
   get "/" $ do

-    posts <- fmap dropExtension <$> liftIO (listDirectory "posts")
-    contents <- mapM render posts
+    posts <- liftIO $ do
+      names <- listDirectory "posts"
+      let files = ("posts" </>) <$> names
+      posts <- catMaybes <$> mapM load files
+      return $ take 5 $ sortOn (Down . date) posts

     html $ renderText $ html_ $ do
     html $ renderText $ html_ $ do

-      head_ style
+      head_ $ style >> title_ "Cool Blog"

       body_ $ do
       body_ $ do

+        p_ $ a_ [href_ "/"] "Cool Blog"

         with form_ [action_ "/login", method_ "post"] $ do
         with form_ [action_ "/login", method_ "post"] $ do

-          input_ [name_ "username", placeholder_ "username", type_ "text"]
-          input_ [name_ "password", placeholder_ "password", type_ "password"]
+          input_ [name_ "username", placeholder_ "Username", type_ "text"]
+          input_ [name_ "password", placeholder_ "Password", type_ "password"]

           input_ [type_ "submit"]
           input_ [type_ "submit"]

-        sequence contents
-
+        sequence (mapMaybe render posts)

 
 

-  get "/post/:post" $ do
-    post <- param "post"
-    content <- render post
+  get "/posts/:post" $ do
+    name <- param "post"
+    mPost <- liftIO $ load ("posts" </> name <.> "md")
+    case mPost of
+      Nothing -> status notFound404
+      Just post ->
+        case render post of
+          Nothing -> status internalServerError500
+          Just content ->

             html $ renderText $ html_ $ do
             html $ renderText $ html_ $ do

-      head_ style
-      body_ content
+              head_ $ style >> title_ "Post"
+              body_ $ do
+                p_ $ a_ [href_ "/"] "Home"
+                content

 
   where
 
   where

-    style = link_ [Attribute "rel" "stylesheet", Attribute "href" "style.css"]
+    style = link_ [Attribute "rel" "stylesheet", Attribute "href" "/style.css"]
+
+data Post = Post
+          { markdown :: T.Text
+          , title    :: T.Text
+          , date     :: UTCTime
+          }

 
 

-render :: String -> ActionM (Html ())
-render post = do
-  let name = "posts" </> post <.> ".md"
-  markdown <- T.toStrict <$> liftIO (T.readFile name)
-  case M.parse name markdown of
-    Left e -> return "shit"
-    Right doc -> return $ M.render (M.useExtensions extensions doc)
+load :: FilePath -> IO (Maybe Post)
+load file = do
+  liftIO $ guard (takeExtension file == ".md")
+  md <- liftIO (T.readFile file)
+  modTime <- getModificationTime file
+  let title = T.pack $ takeBaseName file
+  return $ Just (Post md title modTime)
+
+render :: Post -> Maybe (Html ())
+render p@(Post markdown title date) =
+  case M.parse (pathToPost p) (T.toStrict markdown) of
+    Left e -> Nothing
+    Right doc -> Just $
+      with div_ [id_ (T.toStrict title)] $ do
+        with a_ [href_ (T.toStrict $ linkToPost p)] $
+          i_ $ toHtml $ formatTime defaultTimeLocale "%a %e %B %Y" date
+        br_ []
+        M.render (M.useExtensions extensions doc)

   where extensions = [M.ghcSyntaxHighlighter, M.skylighting, M.footnotes]
   where extensions = [M.ghcSyntaxHighlighter, M.skylighting, M.footnotes]

+
+linkToPost :: Post -> T.Text
+linkToPost p = T.pack $ "/posts" </> T.unpack (title p)
+
+pathToPost :: Post -> FilePath
+pathToPost p = "posts" </> T.unpack (title p) <.> "md"
+
+save :: T.Text -> T.Text -> IO Post
+save md title = do
+  curTime <- getCurrentTime
+  let kTitle = T.pack $ kebab $ T.unpack title
+      p = Post md kTitle curTime
+  T.writeFile (pathToPost p) (markdown p)
+  return p

diff --git a/blog.cabal b/blog.cabal
index 03d4ffa36b94ca272137bec1832d81aaef3e022e..c654987fda79d4b6930832ce91eeba914e0eec9a 100644 (file)
--- a/blog.cabal
+++ b/blog.cabal
@@ -22,4 +22,6 @@ executable blog
         lucid,
         filepath,
         directory,
         lucid,
         filepath,
         directory,

-        http-types
+        http-types,
+        time,
+        casing

diff --git a/posts/hello-again.md b/posts/hello-again.md
new file mode 100644 (file)
index 0000000..af9a93c
--- /dev/null
+++ b/posts/hello-again.md
@@ -0,0 +1,3 @@
+# This is a second stab\r
+\r
+I hope it goes well
\ No newline at end of file

diff --git a/posts/hello.md b/posts/hello.md
deleted file mode 100644 (file)
index 0e50651..0000000
--- a/posts/hello.md
+++ /dev/null
@@ -1,9 +0,0 @@
-# Hello world
-this is the first post
-```haskell
-foo :: Int -> Int
-foo x = 3 - x
-bar = do
-  x <- liftIO $ [x ++ y | x <- z]
-  x <- liftIO $ [x ++ y | x <- z]
-```

diff --git a/posts/oh no.md b/posts/oh no.md
deleted file mode 100644 (file)
index b26e2d1..0000000
--- a/posts/oh no.md
+++ /dev/null
@@ -1,7 +0,0 @@
-# yoga boasdf\r
-\r
-```haskell\r
--- hello world\r
-foo :: Int -> String\r
-foo x = "woops"\r
-```\r

diff --git a/posts/world.md b/posts/world.md
deleted file mode 100644 (file)
index 14a441e..0000000
--- a/posts/world.md
+++ /dev/null
@@ -1 +0,0 @@
-# World
\ No newline at end of file