Commit 8f34b2f7 authored by MrMan's avatar MrMan

First blog post's worth of progress with restish TODO

parents
.stack-work/
haskell-restish-todo.cabal
*~
\ No newline at end of file
- ignore: {name: "Unused LANGUAGE pragma"}
# Changelog for haskell-restish-todo
## Unreleased changes
Copyright 2018 vados <vados@vadosware.io>
Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions:
The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software.
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
\ No newline at end of file
# haskell-restish-todo #
REST-ish TODO application written in [Haskell](https://www.haskell.org/), to go with [a series of blog posts called "REST-ish services in Haskell"](https://vadosware.io/post/rest-ish-services-in-haskell-part-1/) @ [vadosware.io](https://vadosware.io).
This repo contains code that is (hopefully) helpful to those wishing to get started build web services with Haskell, but aren't able to find decent examples for from-scratch projects. Series in the blog posts correspond to tags in this repo (ex. `part-1`, `part-2`, etc).
import Distribution.Simple
main = defaultMain
{-# LANGUAGE RecordWildCards #-}
module Main where
import Config (AppConfig, Host, Port, ProcessEnvironment(..), makeAppConfig)
import Control.Monad (join)
import Data.Semigroup ((<>))
import Lib
import Options.Applicative
import System.Environment (getEnvironment)
import Text.Pretty.Simple (pPrint)
data Options = Options
{ cfgPath :: Maybe FilePath
, cmd :: Command
}
data Command = Serve
| ShowConfig deriving (Eq)
-- | Parser for commands
parseCommands :: Parser Command
parseCommands = subparser commands
where
serverCmd = info (pure Serve) (progDesc "Start the server")
showConfigCmd = info (pure ShowConfig) (progDesc "Show configuration")
commands = command "server" serverCmd
<> command "show-config" showConfigCmd
-- | Parser for top level options
parseOptions :: Parser (Maybe FilePath)
parseOptions = optional
$ strOption ( long "config"
<> short 'c'
<> metavar "FILENAME"
<> help "Configuration file (.json/.toml)" )
-- | Top level optparse-applicative parser for the entire CLI
parseCmdLine :: Parser Options
parseCmdLine = Options <$> parseOptions <*> parseCommands
-- | Helper function to access the environment and marshall it into our newtype
pullEnvironment :: IO ProcessEnvironment
pullEnvironment = ProcessEnvironment <$> getEnvironment
-- | IO action that shows the current loaded configuration
showConfig :: Options -> IO ()
showConfig Options{cfgPath=path} = pullEnvironment
>>= makeAppConfig path
>>= pPrint
-- | IO action that runs the server
runServer :: Options -> IO ()
runServer Options{cfgPath=path} = pullEnvironment
>>= makeAppConfig path
>> server
-- | Start up the server and serve requests
server :: IO ()
server = putStrLn "<SERVER START>"
main :: IO ()
main = parseOptions
>>= process
where
cmdParser = info parseCmdLine idm
parseOptions = execParser cmdParser
process opts = case cmd opts of
Serve -> runServer opts
ShowConfig -> showConfig opts
name: haskell-restish-todo
version: 0.1.0.0
license: BSD3
author: "Author name here"
maintainer: "example@example.com"
copyright: "2018 Author name here"
extra-source-files:
- README.md
- ChangeLog.md
# Metadata used when publishing your package
# synopsis: Short description of your package
# category: Web
# To avoid duplicated efforts in documentation and dealing with the
# complications of embedding Haddock markup inside cabal files, it is
# common to point users to the README.md file.
description: Please see the README on Gitlab at <https://gitlab.com/mrman/haskell-restish-todo#readme>
dependencies:
- base >= 4.7 && < 5
library:
source-dirs:
- src
dependencies:
- servant-server
- htoml
- text
- parsec
- aeson
- bytestring
- system-filepath
executables:
haskell-restish-todo-exe:
main: Main.hs
source-dirs: app
ghc-options:
- -threaded
- -rtsopts
- -with-rtsopts=-N
dependencies:
- haskell-restish-todo
- optparse-applicative
- pretty-simple
tests:
haskell-restish-todo-test:
main: Spec.hs
source-dirs: test
ghc-options:
- -threaded
- -rtsopts
- -with-rtsopts=-N
dependencies:
- haskell-restish-todo
unit:
main: Spec.hs
source-dirs: test/Unit
ghc-options:
- -threaded
- -rtsopts
- -with-rtsopts=-N
dependencies:
- haskell-restish-todo
- hspec
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE StandaloneDeriving #-}
module Config where
import Data.Monoid
import Control.Exception (Exception, try, throw)
import Filesystem.Path as FP
import Filesystem.Path.CurrentOS as FPCOS
import Control.Applicative ((<|>))
import Control.Monad (join, when)
import Data.Maybe (fromMaybe, isJust)
import Data.Aeson (FromJSON(parseJSON), toJSON, eitherDecode)
import Data.Aeson.Types (parseEither)
import Data.Bifunctor (bimap, first, second)
import Data.ByteString.Lazy as DBL
import Data.Functor.Identity
import Data.Text.IO as DTI
import Data.Text as DT
import GHC.Generics
import Text.Parsec.Error (ParseError)
import Text.Read (readMaybe)
import Text.Toml (parseTomlDoc)
type Host = String
type Port = Integer
newtype ProcessEnvironment = ProcessEnvironment {getProcessEnv :: [(String, String)]} deriving (Eq)
data ConfigurationError = ConfigParseError String
| TOMLParserError ParseError
| InvalidConfigError String
| InvalidPath FP.FilePath String
deriving (Eq)
deriving instance Show ConfigurationError
deriving instance Exception ConfigurationError
-- | Parametric polymorphism over type f (e.g. `Identity` or `Maybe`)
data AppConfig f = AppConfig
{ host :: f Host
, port :: f Port
}
type CompleteAppConfig = AppConfig Identity
deriving instance Generic CompleteAppConfig
deriving instance Eq CompleteAppConfig
deriving instance Show CompleteAppConfig
deriving instance FromJSON CompleteAppConfig
type PartialAppConfig = AppConfig Maybe
deriving instance Generic PartialAppConfig
deriving instance Eq PartialAppConfig
deriving instance Show PartialAppConfig
deriving instance FromJSON PartialAppConfig
defaultHost :: Host
defaultHost = "localhost"
defaultPort :: Port
defaultPort = 5000
instance Semigroup CompleteAppConfig where
a <> b = b
instance Monoid CompleteAppConfig where
mempty = AppConfig (Identity defaultHost) (Identity defaultPort)
instance Semigroup PartialAppConfig where
a <> b = AppConfig { host=resolveMaybes host
, port=resolveMaybes port
}
where
resolveMaybes getter = maybe (getter a) Just (getter b)
instance Monoid PartialAppConfig where
mempty = AppConfig Nothing Nothing
----------
-- JSON --
----------
class (FromJSON cfg) => FromJSONFile cfg where
fromJSONFile :: FP.FilePath -> IO (Either ConfigurationError cfg)
instance FromJSONFile PartialAppConfig where
fromJSONFile path = decodeAndTransformError <$> DBL.readFile convertedPath
where
convertedPath = FPCOS.encodeString path
decodeAndTransformError = first ConfigParseError . eitherDecode
----------
-- TOML --
----------
class (FromJSONFile cfg) => FromTOMLFile cfg where
fromTOMLFile :: FP.FilePath -> IO (Either ConfigurationError cfg)
instance FromTOMLFile PartialAppConfig where
fromTOMLFile path = flattenEither . convertAndParse . parseTOML
<$> DTI.readFile convertedPath
where
convertedPath = FPCOS.encodeString path
parseTOML = first TOMLParserError . parseTomlDoc ""
convertAndParse = second (parseEither parseJSON . toJSON)
flattenEither v = case v of
Right (Right cfg) -> Right cfg
Right (Left err) -> Left (ConfigParseError err)
Left err -> Left err
---------
-- ENV --
---------
class FromENV cfg where
fromENV :: ProcessEnvironment -> cfg
instance FromENV PartialAppConfig where
fromENV pEnv = AppConfig { host=prop "TODO_HOST"
, port=readMaybe =<< prop "TODO_PORT"
}
where
env = getProcessEnv pEnv
prop = flip lookup env
mergeInPartial :: CompleteAppConfig -> PartialAppConfig -> CompleteAppConfig
mergeInPartial c p = AppConfig { host = maybe (host c) Identity (host p)
, port = maybe (port c) Identity (port p)
}
-- | Ensure that an Either resolves to it's Right value, ensure that a
rightOrThrow :: (Exception a) => Either a b -> IO b
rightOrThrow e = case e of
(Left err) -> throw err
(Right v) -> return v
buildConfigWithDefault :: CompleteAppConfig -> [PartialAppConfig] -> CompleteAppConfig
buildConfigWithDefault orig partials = orig `mergeInPartial` combinedPartials
where
combinedPartials = Prelude.foldl (<>) (mempty :: PartialAppConfig) partials
-- | Build an App configuration from a given file, using system environment as well as
makeAppConfig :: Maybe Prelude.FilePath -> ProcessEnvironment -> IO (Either ConfigurationError CompleteAppConfig)
makeAppConfig maybeStrPath env = try generateConfig
where
maybePath = FPCOS.fromText . DT.pack <$> maybeStrPath
extension = FP.extension <$> maybePath
isJSONExtension = (==Just "json")
isTOMLExtension = (==Just "toml")
isJSONFile = maybe False isJSONExtension extension
isTOMLFile = maybe False isTOMLExtension extension
pathExtensionIsInvalid = not $ isJSONFile || isTOMLFile
pathInvalidExtensionErr = InvalidPath (fromMaybe "<no path>" maybePath) "Path is invalid (must be either a .json or .toml path)"
envCfg = fromENV env :: PartialAppConfig
fullySpecifiedPartialCfg = mergeInPartial mempty mempty
buildFromEnv = pure $ mergeInPartial fullySpecifiedPartialCfg envCfg
getFileConfig = if isJSONFile then fromJSONFile else fromTOMLFile
generateConfig = maybe buildFromEnv buildFromPathAndEnv maybePath
buildFromPathAndEnv path = when pathExtensionIsInvalid (throw pathInvalidExtensionErr)
>> getFileConfig path
>>= rightOrThrow
>>= \fileCfg -> pure (buildConfigWithDefault (mempty :: CompleteAppConfig) [fileCfg, envCfg])
module Lib
( someFunc
) where
someFunc :: IO ()
someFunc = putStrLn "someFunc"
# 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.12
# 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
{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
module ConfigSpec (spec) where
import Test.Hspec
import Config as C
import Data.Functor.Identity
main :: IO ()
main = hspec spec
completeAppDefault :: CompleteAppConfig
completeAppDefault = C.defaultValue
partialAppDefault :: PartialAppConfig
partialAppDefault = C.defaultValue
spec :: Spec
spec = do
describe "defaults" $ do
it "has localhost as the default host" $
C.defaultHost `shouldBe` "localhost"
it "has 5000 as the default port" $
C.defaultPort `shouldBe` 5000
describe "default values" $ do
it "CompleteAppConfig has default host" $
host completeAppDefault `shouldBe` Identity C.defaultHost
it "CompleteAppConfig has default port" $
port completeAppDefault `shouldBe` Identity C.defaultPort
{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment