Initial commit

diff --git a/.gitignore b/.gitignore
new file mode 100644 (file)
index 0000000..493e06e
--- /dev/null
+++ b/.gitignore
@@ -0,0 +1,6 @@
+dist
+dist-newstyle
+.stack-work
+.ghc.environment*
+*.swp
+*.swo

diff --git a/CHANGELOG.md b/CHANGELOG.md
new file mode 100644 (file)
index 0000000..2675d1c
--- /dev/null
+++ b/CHANGELOG.md
@@ -0,0 +1,5 @@
+# Revision history for blog
+
+## 0.1.0.0 -- YYYY-mm-dd
+
+* First version. Released on an unsuspecting world.

diff --git a/LICENSE b/LICENSE
new file mode 100644 (file)
index 0000000..5e03696
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,30 @@
+Copyright (c) 2018, Luke Lau
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * Redistributions in binary form must reproduce the above
+      copyright notice, this list of conditions and the following
+      disclaimer in the documentation and/or other materials provided
+      with the distribution.
+
+    * Neither the name of Luke Lau nor the names of other
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

diff --git a/Main.hs b/Main.hs
new file mode 100644 (file)
index 0000000..92935c8
--- /dev/null
+++ b/Main.hs
@@ -0,0 +1,72 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Main where
+
+import Web.Scotty
+import qualified Data.Text.Lazy as T
+import qualified Data.Text.Lazy.IO as T
+import Control.Monad.IO.Class
+import Control.Monad
+import qualified Text.MMark as M
+import qualified Text.MMark.Extension.Common as M
+import Lucid
+import Lucid.Base
+import System.Directory
+import System.FilePath
+import Network.HTTP.Types
+
+main :: IO ()
+main = scotty 3000 $ 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"] ""
+      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)
+
+  post "/login" $ do
+    username <- param "username"
+    password <- param "password"
+    if username /= ("luke" :: T.Text) || password /= ("pass" :: T.Text)
+      then status unauthorized401
+      else redirect "/create"
+
+  get "/" $ do
+    posts <- fmap dropExtension <$> liftIO (listDirectory "posts")
+    contents <- mapM render posts
+    html $ renderText $ html_ $ do
+      head_ style
+      body_ $ do
+        with form_ [action_ "/login", method_ "post"] $ do
+          input_ [name_ "username", placeholder_ "username", type_ "text"]
+          input_ [name_ "password", placeholder_ "password", type_ "password"]
+          input_ [type_ "submit"]
+        sequence contents
+
+
+  get "/post/:post" $ do
+    post <- param "post"
+    content <- render post
+    html $ renderText $ html_ $ do
+      head_ style
+      body_ content
+
+  where
+    style = link_ [Attribute "rel" "stylesheet", Attribute "href" "style.css"]
+
+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)
+  where extensions = [M.ghcSyntaxHighlighter, M.skylighting, M.footnotes]

diff --git a/Setup.hs b/Setup.hs
new file mode 100644 (file)
index 0000000..9a994af
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain

diff --git a/blog.cabal b/blog.cabal
new file mode 100644 (file)
index 0000000..03d4ffa
--- /dev/null
+++ b/blog.cabal
@@ -0,0 +1,25 @@
+cabal-version: >=1.10
+name: blog
+version: 0.1.0.0
+license: BSD3
+license-file: LICENSE
+maintainer: luke_lau@icloud.com
+author: Luke Lau
+category: Web
+build-type: Simple
+extra-source-files:
+    CHANGELOG.md
+
+executable blog
+    main-is: Main.hs
+    default-language: Haskell2010
+    build-depends:
+        base >=4.11,
+        scotty,
+        text,
+        mmark,
+        mmark-ext,
+        lucid,
+        filepath,
+        directory,
+        http-types

diff --git a/posts/hello.md b/posts/hello.md
new file mode 100644 (file)
index 0000000..0e50651
--- /dev/null
+++ b/posts/hello.md
@@ -0,0 +1,9 @@
+# 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
new file mode 100644 (file)
index 0000000..b26e2d1
--- /dev/null
+++ b/posts/oh no.md
@@ -0,0 +1,7 @@
+# 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
new file mode 100644 (file)
index 0000000..14a441e
--- /dev/null
+++ b/posts/world.md
@@ -0,0 +1 @@
+# World
\ No newline at end of file

diff --git a/stack.yaml b/stack.yaml
new file mode 100644 (file)
index 0000000..b12eb1e
--- /dev/null
+++ b/stack.yaml
@@ -0,0 +1,65 @@
+# This file was automatically generated by 'stack init'
+#
+# Some commonly used options have been documented as comments in this file.
+# For advanced use and comprehensive documentation of the format, please see:
+# https://docs.haskellstack.org/en/stable/yaml_configuration/
+
+# Resolver to choose a 'specific' stackage snapshot or a compiler version.
+# A snapshot resolver dictates the compiler version and the set of packages
+# to be used for project dependencies. For example:
+#
+# resolver: lts-3.5
+# resolver: nightly-2015-09-21
+# resolver: ghc-7.10.2
+# resolver: ghcjs-0.1.0_ghc-7.10.2
+#
+# The location of a snapshot can be provided as a file or url. Stack assumes
+# a snapshot provided as a file might change, whereas a url resource does not.
+#
+# resolver: ./custom-snapshot.yaml
+# resolver: https://example.com/snapshots/2018-01-01.yaml
+resolver: lts-12.11
+
+# User packages to be built.
+# Various formats can be used as shown in the example below.
+#
+# packages:
+# - some-directory
+# - https://example.com/foo/bar/baz-0.0.2.tar.gz
+# - location:
+#    git: https://github.com/commercialhaskell/stack.git
+#    commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
+# - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a
+#  subdirs:
+#  - auto-update
+#  - wai
+packages:
+- .
+# Dependency packages to be pulled from upstream that are not in the resolver
+# using the same syntax as the packages field.
+# (e.g., acme-missiles-0.3)
+# extra-deps: []
+
+# Override default flag values for local packages and extra-deps
+# flags: {}
+
+# Extra package databases containing global packages
+# extra-package-dbs: []
+
+# Control whether we use the GHC we find on the path
+# system-ghc: true
+#
+# Require a specific version of stack, using version ranges
+# require-stack-version: -any # Default
+# require-stack-version: ">=1.7"
+#
+# Override the architecture used by stack, especially useful on Windows
+# arch: i386
+# arch: x86_64
+#
+# Extra directories used by stack for building
+# extra-include-dirs: [/path/to/dir]
+# extra-lib-dirs: [/path/to/dir]
+#
+# Allow a newer minor version of GHC than the snapshot specifies
+# compiler-check: newer-minor
\ No newline at end of file

diff --git a/style.css b/style.css
new file mode 100644 (file)
index 0000000..9050f5d
--- /dev/null
+++ b/style.css
@@ -0,0 +1,69 @@
+body {
+    font-family: sans-serif;
+}
+
+.source-code .dt {
+    color: #6f42c1
+}
+
+.source-code .dv {
+    color: #fd7e14
+}
+
+.source-code .cf {
+    font-weight: 700;
+    color: #2727af
+}
+
+.source-code .bn {
+    color: #17a2b8
+}
+
+.source-code .fu {
+    color: #007bff
+}
+
+.source-code .kw {
+    font-weight: 700;
+    color: #2727af
+}
+
+.source-code .pr {
+    color: #dc3545
+}
+
+.source-code .sy {
+    color: #e83e8c
+}
+
+.source-code .va {
+    color: #007bff
+}
+
+.source-code .cr {
+    color: #6f42c1
+}
+
+.source-code .op {
+    color: #2727af
+}
+
+.source-code .ch {
+    color: #17a2b8
+}
+
+.source-code .st {
+    color: #20c997
+}
+
+.source-code .it {
+    color: #fd7e14
+}
+
+.source-code .ra {
+    color: #fd7e14
+}
+
+.source-code .co {
+    color: #6c757d
+}