Add rudimentary routing

Also a static icon, which was harder than you might think to get 
working. The typical `getDataFileName` doesn't play nice with new-style 
builds and multi-stage containers. So I ended up with this environment 
variable for the data directory.

.dockerignore

@@ -1,4 +1,7 @@
 *
 
+!/data/
 !/haskellweekly.cabal
+!/LICENSE.markdown
+!/README.markdown
 !/source/

Dockerfile

@@ -8,11 +8,13 @@ FROM alpine:3.10.1
   RUN cabal v2-build --only-dependencies
 
   COPY . .
-  RUN cabal v2-build
-  RUN cp -v "$( cabal v2-exec which haskellweekly )" /usr/local/bin/
+  RUN cabal v2-install .
+  RUN cp ~/.cabal/bin/haskellweekly /usr/local/bin/
 
 FROM alpine:3.10.1
 
   RUN apk add --no-cache gmp libffi libpq
   COPY --from=0 /usr/local/bin/haskellweekly /usr/local/bin/
+  COPY data/ /var/opt/haskellweekly/
+  ENV DATA_DIRECTORY /var/opt/haskellweekly
   CMD haskellweekly

LICENSE.markdown

@@ -0,0 +1,15 @@
+ISC License (ISC)
+
+Copyright 2019 Taylor Fausak
+
+Permission to use, copy, modify, and/or distribute this software for any
+purpose with or without fee is hereby granted, provided that the above
+copyright notice and this permission notice appear in all copies.
+
+THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH
+REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND
+FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT,
+INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM
+LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR
+OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR
+PERFORMANCE OF THIS SOFTWARE.

README.markdown

@@ -0,0 +1,3 @@
+# Haskell Weekly
+
+Publishes curated news about Haskell.

haskellweekly.cabal

@@ -9,10 +9,16 @@ license: ISC
 maintainer: Taylor Fausak
 synopsis: Publishes curated news about Haskell.
 
+data-dir: data
+data-files: favicon.ico
+extra-source-files: README.markdown
+license-file: LICENSE.markdown
+
 common library
   build-depends:
     base ^>= 4.11.1,
     bytestring ^>= 0.10.8,
+    filepath ^>= 1.4.2,
     http-types ^>= 0.12.3,
     lucid ^>= 2.9.11,
     postgresql-simple ^>= 0.6.2,

source/library/HaskellWeekly.hs

@@ -6,6 +6,7 @@ where
 import qualified Control.Exception
 import qualified Data.ByteString
 import qualified Data.ByteString.Lazy
+import qualified Data.Maybe
 import qualified Data.String
 import qualified Data.Text
 import qualified Data.Text.Encoding
@@ -18,6 +19,7 @@ import qualified Network.Wai
 import qualified Network.Wai.Handler.Warp
 import qualified Paths_haskellweekly
 import qualified System.Environment
+import qualified System.FilePath
 import qualified System.IO
 import qualified Text.Printf
 import qualified Text.Read
@@ -37,14 +39,20 @@ defaultMain = do
 
 data Config = Config
   { configDatabaseUrl :: Data.ByteString.ByteString
+  , configDataDirectory :: FilePath
   , configPort :: Network.Wai.Handler.Warp.Port
   } deriving (Eq, Show)
 
 getConfig :: IO Config
 getConfig = do
   databaseUrl <- getDatabaseUrl
+  dataDirectory <- getDataDirectory
   port <- getPort
-  pure Config { configDatabaseUrl = databaseUrl, configPort = port }
+  pure Config
+    { configDatabaseUrl = databaseUrl
+    , configDataDirectory = dataDirectory
+    , configPort = port
+    }
 
 getDatabaseUrl :: IO Data.ByteString.ByteString
 getDatabaseUrl = do
@@ -53,6 +61,11 @@ getDatabaseUrl = do
     Nothing -> Data.ByteString.empty
     Just string -> Data.Text.Encoding.encodeUtf8 $ Data.Text.pack string
 
+getDataDirectory :: IO FilePath
+getDataDirectory = do
+  maybeString <- System.Environment.lookupEnv "DATA_DIRECTORY"
+  pure $ Data.Maybe.fromMaybe "data" maybeString
+
 getPort :: IO Network.Wai.Handler.Warp.Port
 getPort = do
   maybeString <- System.Environment.lookupEnv "PORT"
@@ -90,7 +103,8 @@ logger request status _ =
 
 onExceptionResponse :: Control.Exception.SomeException -> Network.Wai.Response
 onExceptionResponse _ =
-  htmlResponse Network.HTTP.Types.internalServerError500 [] defaultHtml
+  htmlResponse Network.HTTP.Types.internalServerError500 []
+    $ defaultHtml "500 Internal Server Error"
 
 htmlResponse
   :: Network.HTTP.Types.Status
@@ -100,23 +114,31 @@ htmlResponse
 htmlResponse status extraHeaders html =
   let
     body = Lucid.renderBS html
+    contentType =
+      Data.Text.Encoding.encodeUtf8
+        . Data.Text.pack
+        $ "text/html; charset=utf-8"
+    headers = (Network.HTTP.Types.hContentType, contentType) : extraHeaders
+  in lbsResponse status headers body
+
+lbsResponse
+  :: Network.HTTP.Types.Status
+  -> Network.HTTP.Types.ResponseHeaders
+  -> Data.ByteString.Lazy.ByteString
+  -> Network.Wai.Response
+lbsResponse status extraHeaders body =
+  let
     contentLength =
       Data.Text.Encoding.encodeUtf8
         . Data.Text.pack
         . show
         $ Data.ByteString.Lazy.length body
-    contentType =
-      Data.Text.Encoding.encodeUtf8
-        . Data.Text.pack
-        $ "text/html; charset=utf-8"
     headers =
-      (Network.HTTP.Types.hContentLength, contentLength)
-        : (Network.HTTP.Types.hContentType, contentType)
-        : extraHeaders
+      (Network.HTTP.Types.hContentLength, contentLength) : extraHeaders
   in seq contentLength $ Network.Wai.responseLBS status headers body
 
-defaultHtml :: Lucid.Html ()
-defaultHtml = Lucid.doctypehtml_ $ do
+defaultHtml :: String -> Lucid.Html ()
+defaultHtml content = Lucid.doctypehtml_ $ do
   Lucid.head_ $ do
     Lucid.meta_ [Lucid.charset_ $ Data.Text.pack "utf-8"]
     Lucid.meta_
@@ -125,24 +147,65 @@ defaultHtml = Lucid.doctypehtml_ $ do
         $ Data.Text.pack "initial-scale = 1, width = device-width"
       ]
     Lucid.title_ $ Lucid.toHtml "Haskell Weekly"
-  Lucid.body_ . Lucid.h1_ $ Lucid.toHtml "Haskell Weekly"
+  Lucid.body_ $ do
+    Lucid.h1_ $ Lucid.toHtml "Haskell Weekly"
+    Lucid.p_ $ Lucid.toHtml content
 
 serverName :: Data.ByteString.ByteString
 serverName = Data.ByteString.empty
 
-newtype State = State
-  { stateDatabaseConnection :: Database.PostgreSQL.Simple.Connection
+data State = State
+  { stateConfig :: Config
+  , stateDatabaseConnection :: Database.PostgreSQL.Simple.Connection
   }
 
 configToState :: Config -> IO State
 configToState config = do
   databaseConnection <- Database.PostgreSQL.Simple.connectPostgreSQL
     $ configDatabaseUrl config
-  pure State { stateDatabaseConnection = databaseConnection }
+  pure State
+    { stateConfig = config
+    , stateDatabaseConnection = databaseConnection
+    }
 
 stateToApplication :: State -> Network.Wai.Application
-stateToApplication state _request respond = do
-  [[True]] <- Database.PostgreSQL.Simple.query_
-    (stateDatabaseConnection state)
-    (Data.String.fromString "select true")
-  respond $! htmlResponse Network.HTTP.Types.ok200 [] defaultHtml
+stateToApplication state request respond =
+  let
+    path = map Data.Text.unpack $ Network.Wai.pathInfo request
+    method =
+      Data.Text.unpack
+        . Data.Text.Encoding.decodeUtf8With
+            Data.Text.Encoding.Error.lenientDecode
+        $ Network.Wai.requestMethod request
+  in do
+    [[True]] <- Database.PostgreSQL.Simple.query_
+      (stateDatabaseConnection state)
+      (Data.String.fromString "select true")
+    response <- case path of
+      [] -> case method of
+        "GET" -> pure . htmlResponse Network.HTTP.Types.ok200 [] $ defaultHtml
+          "200 OK"
+        _ -> pure notAllowedResponse
+      ["favicon.ico"] -> case method of
+        "GET" -> pure $ Network.Wai.responseFile
+          Network.HTTP.Types.ok200
+          [ ( Network.HTTP.Types.hContentType
+            , Data.Text.Encoding.encodeUtf8 $ Data.Text.pack "image/x-icon"
+            )
+          ]
+          (System.FilePath.combine
+            (configDataDirectory $ stateConfig state)
+            "favicon.ico"
+          )
+          Nothing
+        _ -> pure notAllowedResponse
+      _ -> pure notFoundResponse
+    respond $! response
+
+notAllowedResponse :: Network.Wai.Response
+notAllowedResponse = htmlResponse Network.HTTP.Types.methodNotAllowed405 []
+  $ defaultHtml "405 Method Not Allowed"
+
+notFoundResponse :: Network.Wai.Response
+notFoundResponse =
+  htmlResponse Network.HTTP.Types.notFound404 [] $ defaultHtml "404 Not Found"