Initial commit

.gitignore

@@ -0,0 +1,22 @@
+dist*
+static/tmp/
+static/combined/
+*.hi
+*.o
+*.sqlite3
+*.sqlite3-shm
+*.sqlite3-wal
+.hsenv*
+cabal-dev/
+.stack-work/
+.stack-work-devel/
+yesod-devel/
+.cabal-sandbox
+cabal.sandbox.config
+.DS_Store
+*.swp
+*.keter
+*~
+\#*
+yamgur.cabal
+config.yml

app/devel.hs

@@ -0,0 +1,6 @@
+{-# LANGUAGE PackageImports #-}
+import "yamgur" Application (appMain)
+import Prelude (IO)
+
+main :: IO ()
+main = appMain

app/main.hs

@@ -0,0 +1,5 @@
+import Prelude     (IO)
+import Application (appMain)
+
+main :: IO ()
+main = appMain

package.yaml

@@ -0,0 +1,107 @@
+name:    yamgur
+version: "0.1.0"
+
+dependencies:
+
+- base >=4.9.1.0 && <5
+- yesod >=1.6 && <1.7
+- yesod-core >=1.6 && <1.7
+- yesod-auth >=1.6 && <1.7
+- yesod-static >=1.6 && <1.7
+- yesod-form >=1.6 && <1.7
+- classy-prelude >=1.5 && <1.6
+- classy-prelude-conduit >=1.5 && <1.6
+- classy-prelude-yesod >=1.5 && <1.6
+- bytestring >=0.10 && <0.11
+- text >=0.11 && <2.0
+- persistent >=2.9 && <2.11
+- persistent-sqlite >=2.9 && <2.11
+- persistent-template >=2.5 && <2.9
+- template-haskell
+- shakespeare >=2.0 && <2.1
+- hjsmin >=0.1 && <0.3
+- monad-control >=0.3 && <1.1
+- wai-extra >=3.0 && <3.1
+- yaml >=0.11 && <0.12
+- http-client-tls >=0.3 && <0.4
+- http-conduit >=2.3 && <2.4
+- directory >=1.1 && <1.4
+- warp >=3.0 && <3.4
+- data-default
+- aeson >=1.4 && <1.5
+- conduit >=1.0 && <2.0
+- monad-logger >=0.3 && <0.4
+- fast-logger >=2.2 && <3.1
+- wai-logger >=2.2 && <2.4
+- file-embed
+- safe
+- unordered-containers
+- containers
+- vector
+- time
+- case-insensitive
+- wai
+- foreign-store
+- process
+- directory-tree
+- aeson
+- yesod-auth-oauth2
+- yaml
+- uri-bytestring
+- uri-bytestring-aeson
+
+# The library contains all of our application code. The executable
+# defined below is just a thin wrapper.
+library:
+  source-dirs: src
+  when:
+  - condition: (flag(dev)) || (flag(library-only))
+    then:
+      ghc-options:
+      - -Wall
+      - -fwarn-tabs
+      - -O0
+      cpp-options: -DDEVELOPMENT
+    else:
+      ghc-options:
+      - -Wall
+      - -fwarn-tabs
+      - -O2
+
+# Runnable executable for our application
+executables:
+  yamgur:
+    main: main.hs
+    source-dirs: app
+    ghc-options:
+    - -threaded
+    - -rtsopts
+    - -with-rtsopts=-N
+    dependencies:
+    - yamgur
+    when:
+    - condition: flag(library-only)
+      buildable: false
+
+# Test suite
+tests:
+  yamgur-test:
+    main: Spec.hs
+    source-dirs: test
+    ghc-options: -Wall
+    dependencies:
+    - yamgur
+    - hspec >=2.0.0
+    - yesod-test
+    - microlens
+
+# Define flags used by "yesod devel" to make compilation faster
+flags:
+  library-only:
+    description: Build for use with "yesod devel"
+    manual: false
+    default: false
+  dev:
+    description: Turn on development settings, like auto-reload templates.
+    manual: false
+    default: false

src/Application.hs

@@ -0,0 +1,66 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module Application where
+
+import ClassyPrelude.Yesod (newManager)
+import GenericOIDC (oidcAuth')
+import Yesod
+import Yesod.Auth
+import Yesod.Auth.OAuth2.Prelude
+import Prelude
+import YamgurConfig
+import Data.Yaml.Aeson (decodeFileEither)
+
+data Yamgur = Yamgur
+  { httpManager :: Manager,
+    config :: YamgurConfig
+  }
+
+mkYesod
+  "Yamgur"
+  [parseRoutes|
+/auth AuthR Auth getAuth
+/     HomeR GET
+|]
+
+instance Yesod Yamgur where
+  approot = ApprootMaster $ host . config
+
+instance YesodAuth Yamgur where
+  type AuthId Yamgur = Text
+  authenticate = return . Authenticated . credsIdent
+  loginDest _ = HomeR
+  logoutDest _ = HomeR
+  authPlugins y = [oidcAuth' $ oidc $ config y]
+  maybeAuthId = lookupSession "_ID"
+
+instance RenderMessage Yamgur FormMessage where
+  renderMessage _ _ = defaultFormMessage
+
+getHomeR :: Handler Html
+getHomeR = do
+  maid <- maybeAuthId
+  defaultLayout
+        [whamlet|
+            <p>Your current auth ID: #{show maid}
+            $maybe _ <- maid
+                <p>
+                    <a href=@{AuthR LogoutR}>Logout
+            $nothing
+                <p>
+                    <a href=@{AuthR LoginR}>Go to the login page
+        |]
+
+appMain :: IO ()
+appMain = do
+  c' <- decodeFileEither "config.yml"
+  case c' of 
+    Left e -> error $ "Could not parse config file: " <> show e
+    Right c -> do
+      putStrLn $ "Launching application at " <> show (host c)
+      m <- newManager
+      warp 3001 $ Yamgur m c

src/GenericOIDC.hs

@@ -0,0 +1,49 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+
+module GenericOIDC (oidcAuth, oidcAuth') where
+
+import ClassyPrelude.Yesod (WidgetFor, whamlet)
+import Yesod.Auth.OAuth2.Prelude
+import YamgurConfig
+
+
+pluginName :: Text
+pluginName = "oidc"
+
+newtype User = User Text
+
+instance FromJSON User where
+  parseJSON =
+    withObject "User" $ \o ->
+      User
+        <$> (("uid:" <>) <$> o .: "sub")
+
+oidcAuth' :: YesodAuth m => OIDCConfig -> AuthPlugin m
+oidcAuth' = oidcAuth [whamlet|Login via #{pluginName}|]
+
+oidcAuth :: YesodAuth m => WidgetFor m () -> OIDCConfig -> AuthPlugin m
+oidcAuth widget config =
+  authOAuth2Widget widget pluginName oauth2 $ \manager token -> do
+    (User userId, userResponse) <-
+      authGetProfile
+        pluginName
+        manager
+        token
+        "https://keycloak.dfsek.com/realms/dfsek.com/protocol/openid-connect/userinfo"
+    print userResponse
+    pure
+      Creds
+        { credsPlugin = pluginName,
+          credsIdent = userId,
+          credsExtra = setExtra token userResponse
+        }
+  where
+    oauth2 =
+      OAuth2
+        { oauth2ClientId = oidc_client_id config,
+          oauth2ClientSecret = Just $ oidc_secret config,
+          oauth2AuthorizeEndpoint = "https://keycloak.dfsek.com/realms/dfsek.com/protocol/openid-connect/auth",
+          oauth2TokenEndpoint = "https://keycloak.dfsek.com/realms/dfsek.com/protocol/openid-connect/token",
+          oauth2RedirectUri = Nothing
+        }

src/YamgurConfig.hs

@@ -0,0 +1,28 @@
+
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE DeriveAnyClass #-}
+
+module YamgurConfig(OIDCConfig(..), YamgurConfig(..)) where
+
+import Data.Text (Text)
+import URI.ByteString
+import Data.Aeson
+import ClassyPrelude.Conduit (Generic)
+import URI.ByteString.Aeson
+
+newtype AbsoluteURI = URIRef Absolute deriving (Generic)
+
+data YamgurConfig = YamgurConfig
+  { oidc :: OIDCConfig,
+  host :: Text
+  } deriving (Generic, FromJSON)
+
+data OIDCConfig = OIDCConfig
+  { oidc_secret :: Text,
+    oidc_client_id :: Text,
+    oidc_token_url :: URIRef Absolute,
+    oidc_auth_url :: URIRef Absolute
+  } deriving (Generic, FromJSON)
+

stack.yaml

@@ -0,0 +1,68 @@
+# 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
+#
+# 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:
+  url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/16/31.yaml
+
+# 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
+#   subdirs:
+#   - auto-update
+#   - wai
+packages:
+  - .
+# Dependency packages to be pulled from upstream that are not in the resolver.
+# These entries can reference officially published versions as well as
+# forks / in-progress versions pinned to a git hash. For example:
+#
+# extra-deps:
+# - acme-missiles-0.3
+# - git: https://github.com/commercialhaskell/stack.git
+#   commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
+#
+extra-deps:
+  - yesod-auth-oauth2-0.7.0.2@sha256:b1dabedb8a22a97d74febd3d76b764596847ad1a5e40dd473ffb5d4098723bf3,3410
+
+# 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: ">=2.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

test/Handler/CommentSpec.hs

@@ -0,0 +1,47 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE OverloadedStrings #-}
+module Handler.CommentSpec (spec) where
+
+import TestImport
+import Data.Aeson
+
+spec :: Spec
+spec = withApp $ do
+    describe "valid request" $ do
+        it "gives a 200" $ do
+            get HomeR
+            statusIs 200
+
+            let message = "My message" :: Text
+                body = object [ "message" .= message ]
+                encoded = encode body
+
+            request $ do
+                setMethod "POST"
+                setUrl CommentR
+                setRequestBody encoded
+                addRequestHeader ("Content-Type", "application/json")
+
+            statusIs 200
+
+            comments <- runDB $ selectList [CommentMessage ==. message] []
+            Entity _id comment <-
+                case comments of
+                    [ent] -> pure ent
+                    _ -> error "needed 1 entity"
+            assertEq "Should have " comment (Comment message Nothing)
+
+    describe "invalid requests" $ do
+        it "400s when the JSON body is invalid" $ do
+            get HomeR
+
+            let body = object [ "foo" .= ("My message" :: Value) ]
+
+            request $ do
+                setMethod "POST"
+                setUrl CommentR
+                setRequestBody $ encode body
+                addRequestHeader ("Content-Type", "application/json")
+
+            statusIs 400
+

test/Handler/CommonSpec.hs

@@ -0,0 +1,17 @@
+module Handler.CommonSpec (spec) where
+
+import TestImport
+
+spec :: Spec
+spec = withApp $ do
+    describe "robots.txt" $ do
+        it "gives a 200" $ do
+            get RobotsR
+            statusIs 200
+        it "has correct User-agent" $ do
+            get RobotsR
+            bodyContains "User-agent: *"
+    describe "favicon.ico" $ do
+        it "gives a 200" $ do
+            get FaviconR
+            statusIs 200

test/Handler/HomeSpec.hs

@@ -0,0 +1,35 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE OverloadedStrings #-}
+module Handler.HomeSpec (spec) where
+
+import TestImport
+
+spec :: Spec
+spec = withApp $ do
+
+    describe "Homepage" $ do
+        it "loads the index and checks it looks right" $ do
+          get HomeR
+          statusIs 200
+          htmlAnyContain "h1" "a modern framework for blazing fast websites"
+
+          request $ do
+              setMethod "POST"
+              setUrl HomeR
+              addToken
+              fileByLabelExact "Choose a file" "test/Spec.hs" "text/plain" -- talk about self-reference
+              byLabelExact "What's on the file?" "Some Content"
+
+          statusIs 200
+          -- more debugging printBody
+          htmlAllContain ".upload-response" "text/plain"
+          htmlAllContain ".upload-response" "Some Content"
+
+        -- This is a simple example of using a database access in a test.  The
+        -- test will succeed for a fresh scaffolded site with an empty database,
+        -- but will fail on an existing database with a non-empty user table.
+        it "leaves the user table empty" $ do
+          get HomeR
+          statusIs 200
+          users <- runDB $ selectList ([] :: [Filter User]) []
+          assertEq "user table empty" 0 $ length users

test/Handler/ProfileSpec.hs

@@ -0,0 +1,28 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE OverloadedStrings #-}
+module Handler.ProfileSpec (spec) where
+
+import TestImport
+
+spec :: Spec
+spec = withApp $ do
+
+    describe "Profile page" $ do
+        it "asserts no access to my-account for anonymous users" $ do
+            get ProfileR
+            statusIs 403
+
+        it "asserts access to my-account for authenticated users" $ do
+            userEntity <- createUser "foo"
+            authenticateAs userEntity
+
+            get ProfileR
+            statusIs 200
+
+        it "asserts user's information is shown" $ do
+            userEntity <- createUser "bar"
+            authenticateAs userEntity
+
+            get ProfileR
+            let (Entity _ user) = userEntity
+            htmlAnyContain ".username" . unpack $ userIdent user

test/Spec.hs

@@ -0,0 +1 @@
+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}

test/TestImport.hs

@@ -0,0 +1,103 @@
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE OverloadedStrings #-}
+module TestImport
+    ( module TestImport
+    , module X
+    ) where
+
+import Application           (makeFoundation, makeLogWare)
+import ClassyPrelude         as X hiding (delete, deleteBy, Handler)
+import Database.Persist      as X hiding (get)
+import Database.Persist.Sql  (SqlPersistM, runSqlPersistMPool, rawExecute, rawSql, unSingle, connEscapeName)
+import Foundation            as X
+import Model                 as X
+import Test.Hspec            as X
+import Yesod.Default.Config2 (useEnv, loadYamlSettings)
+import Yesod.Auth            as X
+import Yesod.Test            as X
+import Yesod.Core.Unsafe     (fakeHandlerGetLogger)
+
+-- Wiping the database
+import Database.Persist.Sqlite              (sqlDatabase, mkSqliteConnectionInfo, fkEnabled, createSqlitePoolFromInfo)
+import Control.Monad.Logger                 (runLoggingT)
+import Lens.Micro                           (set)
+import Settings (appDatabaseConf)
+import Yesod.Core (messageLoggerSource)
+
+runDB :: SqlPersistM a -> YesodExample App a
+runDB query = do
+    pool <- fmap appConnPool getTestYesod
+    liftIO $ runSqlPersistMPool query pool
+
+runHandler :: Handler a -> YesodExample App a
+runHandler handler = do
+    app <- getTestYesod
+    fakeHandlerGetLogger appLogger app handler
+
+withApp :: SpecWith (TestApp App) -> Spec
+withApp = before $ do
+    settings <- loadYamlSettings
+        ["config/test-settings.yml", "config/settings.yml"]
+        []
+        useEnv
+    foundation <- makeFoundation settings
+    wipeDB foundation
+    logWare <- liftIO $ makeLogWare foundation
+    return (foundation, logWare)
+
+-- This function will truncate all of the tables in your database.
+-- 'withApp' calls it before each test, creating a clean environment for each
+-- spec to run in.
+wipeDB :: App -> IO ()
+wipeDB app = do
+    -- In order to wipe the database, we need to use a connection which has
+    -- foreign key checks disabled.  Foreign key checks are enabled or disabled
+    -- per connection, so this won't effect queries outside this function.
+    --
+    -- Aside: foreign key checks are enabled by persistent-sqlite, as of
+    -- version 2.6.2, unless they are explicitly disabled in the
+    -- SqliteConnectionInfo.
+
+    let logFunc = messageLoggerSource app (appLogger app)
+
+    let dbName = sqlDatabase $ appDatabaseConf $ appSettings app
+        connInfo = set fkEnabled False $ mkSqliteConnectionInfo dbName
+
+    pool <- runLoggingT (createSqlitePoolFromInfo connInfo 1) logFunc
+
+    flip runSqlPersistMPool pool $ do
+        tables <- getTables
+        sqlBackend <- ask
+        let queries = map (\t -> "DELETE FROM " ++ (connEscapeName sqlBackend $ DBName t)) tables
+        forM_ queries (\q -> rawExecute q [])
+
+getTables :: DB [Text]
+getTables = do
+    tables <- rawSql "SELECT name FROM sqlite_master WHERE type = 'table';" []
+    return (fmap unSingle tables)
+
+-- | Authenticate as a user. This relies on the `auth-dummy-login: true` flag
+-- being set in test-settings.yaml, which enables dummy authentication in
+-- Foundation.hs
+authenticateAs :: Entity User -> YesodExample App ()
+authenticateAs (Entity _ u) = do
+    request $ do
+        setMethod "POST"
+        addPostParam "ident" $ userIdent u
+        setUrl $ AuthR $ PluginR "dummy" []
+
+-- | Create a user.  The dummy email entry helps to confirm that foreign-key
+-- checking is switched off in wipeDB for those database backends which need it.
+createUser :: Text -> YesodExample App (Entity User)
+createUser ident = runDB $ do
+    user <- insertEntity User
+        { userIdent = ident
+        , userPassword = Nothing
+        }
+    _ <- insert Email
+        { emailEmail = ident
+        , emailUserId = Just $ entityKey user
+        , emailVerkey = Nothing
+        }
+    return user