From: Luke Lau Date: Wed, 3 Oct 2018 19:48:08 +0000 (+0100) Subject: Initial commit X-Git-Url: https://git.lukelau.me/?p=blog.git;a=commitdiff_plain;h=0848263e3bc89a44d351980eef66207931eaa7aa Initial commit --- 0848263e3bc89a44d351980eef66207931eaa7aa diff --git a/.gitignore b/.gitignore new file mode 100644 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 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 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 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 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 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 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 index 0000000..b26e2d1 --- /dev/null +++ b/posts/oh no.md @@ -0,0 +1,7 @@ +# yoga boasdf + +```haskell +-- hello world +foo :: Int -> String +foo x = "woops" +``` diff --git a/posts/world.md b/posts/world.md new file mode 100644 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 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 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 +}