├── .ghci ├── .gitignore ├── .gitmodules ├── .lvimrc ├── .stylish-haskell.yaml ├── .travis.yml ├── Application.hs ├── LICENSE ├── README.md ├── Setup.hs ├── app └── Main.hs ├── config └── keter.yaml ├── deploy.sh ├── quicklift.cabal ├── src ├── Api.hs ├── Authentication.hs ├── Config.hs ├── Models.hs ├── Parser.hs ├── Server.hs ├── Users.hs ├── Users │ └── TH.hs └── Util.hs ├── stack.yaml └── test ├── ParserSpec.hs └── Spec.hs /.ghci: -------------------------------------------------------------------------------- 1 | :l test/Spec.hs 2 | main 3 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | **/*.keter 3 | **/*.log 4 | .stack-work/ 5 | cabal-dev 6 | *.o 7 | *.hi 8 | *.chi 9 | **/*.dump-hi 10 | *.chs.h 11 | *.dyn_o 12 | *.dyn_hi 13 | .virtualenv 14 | .hpc 15 | .hsenv 16 | .cabal-sandbox/ 17 | cabal.sandbox.config 18 | *.prof 19 | *.aux 20 | *.hp 21 | dist 22 | cabal-dev 23 | *.o 24 | *.hi 25 | *.chi 26 | *.chs.h 27 | *.dyn_o 28 | *.dyn_hi 29 | .virtualenv 30 | .hpc 31 | .hsenv 32 | .cabal-sandbox/ 33 | cabal.sandbox.config 34 | *.prof 35 | *.aux 36 | *.hp 37 | -------------------------------------------------------------------------------- /.gitmodules: -------------------------------------------------------------------------------- 1 | [submodule "ql-ui"] 2 | path = ql-ui 3 | url = git@github.com:parsonsmatt/ql-purs 4 | -------------------------------------------------------------------------------- /.lvimrc: -------------------------------------------------------------------------------- 1 | set tabstop=4 2 | set shiftwidth=4 3 | set softtabstop=4 4 | 5 | set expandtab 6 | set nosmarttab 7 | -------------------------------------------------------------------------------- /.stylish-haskell.yaml: -------------------------------------------------------------------------------- 1 | # stylish-haskell configuration file 2 | # ================================== 3 | 4 | # The stylish-haskell tool is mainly configured by specifying steps. These steps 5 | # are a list, so they have an order, and one specific step may appear more than 6 | # once (if needed). Each file is processed by these steps in the given order. 7 | steps: 8 | # Convert some ASCII sequences to their Unicode equivalents. This is disabled 9 | # by default. 10 | # - unicode_syntax: 11 | # # In order to make this work, we also need to insert the UnicodeSyntax 12 | # # language pragma. If this flag is set to true, we insert it when it's 13 | # # not already present. You may want to disable it if you configure 14 | # # language extensions using some other method than pragmas. Default: 15 | # # true. 16 | # add_language_pragma: true 17 | 18 | # Import cleanup 19 | - imports: 20 | # There are different ways we can align names and lists. 21 | # 22 | # - global: Align the import names and import list throughout the entire 23 | # file. 24 | # 25 | # - file: Like global, but don't add padding when there are no qualified 26 | # imports in the file. 27 | # 28 | # - group: Only align the imports per group (a group is formed by adjacent 29 | # import lines). 30 | # 31 | # - none: Do not perform any alignment. 32 | # 33 | # Default: global. 34 | align: global 35 | 36 | # Language pragmas 37 | - language_pragmas: 38 | # We can generate different styles of language pragma lists. 39 | # 40 | # - vertical: Vertical-spaced language pragmas, one per line. 41 | # 42 | # - compact: A more compact style. 43 | # 44 | # - compact_line: Similar to compact, but wrap each line with 45 | # `{-#LANGUAGE #-}'. 46 | # 47 | # Default: vertical. 48 | style: vertical 49 | 50 | # stylish-haskell can detect redundancy of some language pragmas. If this 51 | # is set to true, it will remove those redundant pragmas. Default: true. 52 | remove_redundant: true 53 | 54 | # Align the types in record declarations 55 | - records: {} 56 | 57 | # Replace tabs by spaces. This is disabled by default. 58 | # - tabs: 59 | # # Number of spaces to use for each tab. Default: 8, as specified by the 60 | # # Haskell report. 61 | # spaces: 8 62 | 63 | # Remove trailing whitespace 64 | - trailing_whitespace: {} 65 | 66 | # A common setting is the number of columns (parts of) code will be wrapped 67 | # to. Different steps take this into account. Default: 80. 68 | columns: 80 69 | 70 | # Sometimes, language extensions are specified in a cabal file or from the 71 | # command line instead of using language pragmas in the file. stylish-haskell 72 | # needs to be aware of these, so it can parse the file correctly. 73 | # 74 | # No language extensions are enabled by default. 75 | language_extensions: [] 76 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | # Use new container infrastructure to enable caching 2 | sudo: false 3 | 4 | # thanks to http://stackoverflow.com/a/24600210/3780203 5 | # Handle git submodules yourself 6 | git: 7 | submodules: false 8 | # Use sed to replace the SSH URL with the public URL, then initialize submodules 9 | before_install: 10 | - sed -i 's/git@github.com:/https:\/\/github.com\//' .gitmodules 11 | - git submodule update --init --recursive 12 | 13 | 14 | # Choose a lightweight base image; we provide our own build tools. 15 | language: c 16 | 17 | # GHC depends on GMP. You can add other dependencies here as well. 18 | addons: 19 | apt: 20 | packages: 21 | - libgmp-dev 22 | 23 | # The different configurations we want to test. You could also do things like 24 | # change flags or use --stack-yaml to point to a different file. 25 | env: 26 | - ARGS="" 27 | 28 | before_install: 29 | # Download and unpack the stack executable 30 | - mkdir -p ~/.local/bin 31 | - export PATH=$HOME/.local/bin:$PATH 32 | - travis_retry curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack' 33 | 34 | # This line does all of the work: installs GHC if necessary, build the library, 35 | # executables, and test suites, and runs the test suites. --no-terminal works 36 | # around some quirks in Travis's terminal implementation. 37 | script: stack --no-terminal --install-ghc test 38 | 39 | # Caching so the next build will be fast too. 40 | cache: 41 | directories: 42 | - $HOME/.stack 43 | -------------------------------------------------------------------------------- /Application.hs: -------------------------------------------------------------------------------- 1 | module Application where 2 | 3 | import Server 4 | 5 | develMain :: IO () 6 | develMain = quickLift 7 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2015 Matt Parsons 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be included 12 | in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 17 | IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY 18 | CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, 19 | TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE 20 | SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # QuickLift 2 | 3 | [![Build Status](https://travis-ci.org/parsonsmatt/QuickLift.svg?branch=master)](https://travis-ci.org/parsonsmatt/QuickLift) 4 | 5 | QuickLift is a web app for logging weightlifting sessions. 6 | 7 | I've used a few of the currently available weightlifting apps, and they all suffer from some key problems: 8 | 9 | - The UI is slow, unintuitive, or frustrating to use 10 | - There is no planning capacity built into the service 11 | - There is no analysis built into the service 12 | 13 | I want to build a weightlifting logging application that works great on mobile, is lightning fast to use, and (eventually) provides awesome analysis. 14 | 15 | ## Installation 16 | 17 | - Download and install [stack](https://github.com/commercialhaskell/stack) 18 | - Run `stack build` to build the project 19 | - Run `stack test` to run the tests 20 | 21 | ### Database 22 | 23 | - Ensure that PostgreSQL is installed. 24 | - Create a database `quicklift` with `username:password` of `test:test` 25 | 26 | ### Front end 27 | 28 | There are three main ways to use the front-end: 29 | 30 | 1. `pulp server` for fast refresh that doesn't rely on the back end. 31 | 2. `./dev` script which watches the source and rebuilds on changes. 32 | 3. `./deploy` script which installs all dependencies and does an optimized build. 33 | 34 | ## Features on the way 35 | 36 | * Authentication 37 | * Weightlifting Logging 38 | * Deployment! 39 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /app/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Server 4 | 5 | main :: IO () 6 | main = quickLift 7 | -------------------------------------------------------------------------------- /config/keter.yaml: -------------------------------------------------------------------------------- 1 | exec: ../quicklift-exe 2 | host: quicklift.parsonsmatt.org 3 | requires-secure: false 4 | 5 | plugins: 6 | postgres: true 7 | -------------------------------------------------------------------------------- /deploy.sh: -------------------------------------------------------------------------------- 1 | #! /bin/bash 2 | 3 | set -e 4 | echo "Building QuickLift..." 5 | stack build 6 | strip `stack exec -- which quicklift-exe` 7 | echo "Building assets..." 8 | cd ql-ui 9 | deploy 10 | cd .. 11 | echo "Creating bundle..." 12 | cp `stack exec -- which quicklift-exe` quicklift-exe 13 | tar -czvf quicklift.keter quicklift-exe config ql-ui/assets 14 | rm quicklift-exe 15 | scp ./quicklift.keter root@104.236.4.9:/opt/keter/incoming/quicklift.keter 16 | rm quicklift.keter 17 | -------------------------------------------------------------------------------- /quicklift.cabal: -------------------------------------------------------------------------------- 1 | -- Initial QuickLift.cabal generated by cabal init. For further 2 | -- documentation, see http://haskell.org/cabal/users-guide/ 3 | 4 | name: quicklift 5 | version: 0.1.0.0 6 | synopsis: RESTful API for weightlifting 7 | description: RESTful API for weightlifting 8 | license: MIT 9 | license-file: LICENSE 10 | author: Matt Parsons 11 | maintainer: parsonsmatt@gmail.com 12 | -- copyright: 13 | category: Web 14 | build-type: Simple 15 | -- extra-source-files: 16 | cabal-version: >=1.10 17 | 18 | source-repository head 19 | type: git 20 | location: https://www.github.com/parsonsmatt/QuickLift 21 | 22 | executable quicklift-exe 23 | hs-source-dirs: app 24 | main-is: Main.hs 25 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 26 | build-depends: base, quicklift 27 | default-language: Haskell2010 28 | 29 | 30 | library 31 | exposed-modules: 32 | Api 33 | , Config 34 | , Models 35 | , Parser 36 | , Server 37 | , Authentication 38 | , Users 39 | , Users.TH 40 | , Util 41 | 42 | -- other-extensions: 43 | build-depends: 44 | base >=4.6 && <4.10 45 | , aeson 46 | , bytestring 47 | , either 48 | , lens 49 | , megaparsec 50 | , monad-control 51 | , monad-loops 52 | , monad-logger 53 | , mtl 54 | , persistent 55 | , persistent-postgresql 56 | , persistent-template 57 | , pwstore-fast 58 | , scientific 59 | , servant >= 0.5 && < 0.6 60 | , servant-server >= 0.5 && < 0.6 61 | , template-haskell 62 | , text 63 | , time 64 | , transformers 65 | , users 66 | , users-persistent 67 | , wai 68 | , wai-extra 69 | , warp 70 | hs-source-dirs: src 71 | default-language: Haskell2010 72 | 73 | 74 | test-suite quicklift-test 75 | type: exitcode-stdio-1.0 76 | hs-source-dirs: test 77 | main-is: Spec.hs 78 | build-depends: base 79 | , parsec 80 | , quicklift 81 | , QuickCheck 82 | , hspec 83 | , QuasiText 84 | , scientific 85 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 86 | default-language: Haskell2010 87 | -------------------------------------------------------------------------------- /src/Api.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE RecordWildCards #-} 3 | {-# LANGUAGE TypeOperators #-} 4 | 5 | module Api where 6 | 7 | import Config 8 | import Control.Monad 9 | import Control.Monad.Except 10 | import Control.Monad.Reader 11 | import Control.Monad.Trans.Except 12 | import Control.Monad.Trans.Maybe 13 | import Crypto.PasswordStore 14 | import qualified Data.ByteString.Char8 as BS 15 | import Data.Int 16 | import Data.Maybe 17 | import Data.Text (Text) 18 | import qualified Data.Text as Text 19 | import qualified Data.Text.Encoding as Text 20 | import Database.Persist 21 | import Database.Persist.Postgresql 22 | import Debug.Trace 23 | import Models 24 | import Network.Wai 25 | import Servant 26 | import Users 27 | import qualified Web.Users.Persistent as WU 28 | import qualified Web.Users.Types as WU 29 | 30 | type QuickLiftAPI 31 | = "users" :> UserAPI 32 | :<|> "lifters" :> LifterAPI 33 | 34 | type UserAPI = Get '[JSON] [Person] 35 | :<|> ReqBody '[JSON] Registration :> Post '[JSON] (Either Text.Text AuthResponse) 36 | :<|> "login" :> ReqBody '[JSON] Auth :> Post '[JSON] (Maybe AuthResponse) 37 | :<|> "verify" :> ReqBody '[JSON] Text :> Post '[JSON] (Maybe AuthResponse) 38 | 39 | type LifterAPI = Get '[JSON] [Person] 40 | :<|> Capture "name" Text :> (Get '[JSON] Person 41 | :<|> "sessions" :> SessionAPI) 42 | 43 | type SessionAPI = Get '[JSON] [Entity Liftsession] 44 | :<|> Header "auth" Text :> ReqBody '[JSON] Liftsession :> Post '[JSON] (Either Text Int64) 45 | 46 | userServer :: ServerT UserAPI AppM 47 | userServer = getUsers :<|> registerUser :<|> authenticateUser 48 | :<|> verifyToken 49 | 50 | lifterServer :: ServerT LifterAPI AppM 51 | lifterServer = getUsers :<|> (\t -> getUser t :<|> sessionServer t) 52 | 53 | verifyToken :: Text -> AppM (Maybe AuthResponse) 54 | verifyToken sid = runMaybeT $ do 55 | let session = WU.SessionId sid 56 | userId <- MaybeT $ verifySession session 12000 57 | user <- MaybeT $ getUserById userId 58 | return (AuthResponse session (userToPerson userId user)) 59 | 60 | sessionServer :: Text -> ServerT SessionAPI AppM 61 | sessionServer username = getSessions' :<|> createSession' 62 | where 63 | getSessions' :: AppM [Entity Liftsession] 64 | getSessions' = getUser username >>= getSessions 65 | 66 | createSession' :: Maybe Text -> Liftsession -> AppM (Either Text Int64) 67 | createSession' Nothing _ = lift $ throwE err401 68 | createSession' (Just sid) s = do 69 | loginId <- verifySession (WU.SessionId sid) 10 70 | user <- getUser username 71 | if loginId == Just (personId user) 72 | then createSession s user 73 | else lift $ throwE err401 74 | 75 | getSessions :: Person -> AppM [Entity Liftsession] 76 | getSessions Person {..} = 77 | runDb $ selectList [ LiftsessionUser ==. personId ] [] 78 | 79 | createSession :: Liftsession -> Person -> AppM (Either Text Int64) 80 | createSession ls person = do 81 | let ls' = ls { liftsessionUser = personId person } 82 | key <- runDb $ insert ls' 83 | return . return . fromSqlKey $ key 84 | 85 | getUsers :: AppM [Person] 86 | getUsers = do 87 | users <- listUsers Nothing 88 | return (fmap (uncurry userToPerson) users) 89 | 90 | getUser :: Text -> AppM Person 91 | getUser k = do 92 | person <- runMaybeT $ do 93 | userid <- MaybeT $ getUserIdByName k 94 | user <- MaybeT $ getUserById userid 95 | return $ userToPerson userid user 96 | maybe (lift $ throwE err404) return person 97 | 98 | registerUser :: Registration -> AppM (Either Text.Text AuthResponse) 99 | registerUser reg = do 100 | let qlUser = convertRegistration reg 101 | auth = (Auth <$> regEmail <*> regPassword) reg 102 | user <- createUser qlUser 103 | case user of 104 | Left e -> return . Left . Text.pack . show $ 3 105 | Right u -> do 106 | Just authResp <- authenticateUser auth 107 | return . return $ authResp 108 | 109 | authenticateUser :: Auth -> AppM (Maybe AuthResponse) 110 | authenticateUser auth = runMaybeT $ do 111 | sessionId <- MaybeT $ authUser (authEmail auth) (WU.PasswordPlain $ authPassword auth) 12000000 112 | person <- lift $ getUser (authEmail auth) 113 | return $ AuthResponse sessionId person 114 | 115 | 116 | server :: ServerT QuickLiftAPI AppM 117 | server = userServer :<|> lifterServer 118 | 119 | quickliftAPI :: Proxy QuickLiftAPI 120 | quickliftAPI = Proxy 121 | 122 | type AppAPI = QuickLiftAPI :<|> Raw 123 | 124 | appAPI :: Proxy AppAPI 125 | appAPI = Proxy 126 | 127 | files :: Application 128 | files = serveDirectory "ql-ui/assets/" 129 | 130 | app :: Config -> Application 131 | app cfg = serve appAPI (readerServer cfg :<|> files) 132 | 133 | readerServer :: Config -> Server QuickLiftAPI 134 | readerServer cfg = enter (runReaderTNat cfg) server 135 | -------------------------------------------------------------------------------- /src/Authentication.hs: -------------------------------------------------------------------------------- 1 | module Authentication where 2 | 3 | import Crypto.PasswordStore 4 | import Data.ByteString 5 | -------------------------------------------------------------------------------- /src/Config.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Config where 4 | 5 | import Control.Monad.Except 6 | import Control.Monad.Logger 7 | import Control.Monad.Reader 8 | import Control.Monad.Trans.Maybe 9 | import qualified Data.ByteString.Char8 as BS 10 | import Data.Monoid ((<>)) 11 | import Network.Wai 12 | import Network.Wai.Middleware.RequestLogger 13 | import Servant 14 | import System.Environment (lookupEnv) 15 | 16 | import Database.Persist.Postgresql 17 | 18 | data Config 19 | = Config 20 | { getPool :: ConnectionPool 21 | , getEnv :: Environment 22 | } 23 | 24 | type AppM = ReaderT Config (ExceptT ServantErr IO) 25 | 26 | data Environment 27 | = Development 28 | | Test 29 | | Production 30 | deriving (Eq, Show, Read) 31 | 32 | defaultConfig :: Config 33 | defaultConfig 34 | = Config 35 | { getPool = undefined 36 | , getEnv = Development 37 | } 38 | 39 | setLogger :: Environment -> Middleware 40 | setLogger Test = id 41 | setLogger Development = logStdoutDev 42 | setLogger Production = logStdout 43 | 44 | makePool :: Environment -> IO ConnectionPool 45 | makePool Test = runNoLoggingT $ createPostgresqlPool (connStr Test) (envPool Test) 46 | makePool Development = runStdoutLoggingT $ createPostgresqlPool (connStr Development) (envPool Development) 47 | makePool Production = do 48 | pool <- runMaybeT $ do 49 | let keys = fmap BS.pack 50 | [ "host=" 51 | , "port=" 52 | , "user=" 53 | , "password=" 54 | , "dbname=" 55 | ] 56 | envs = [ "PGHOST" 57 | , "PGPORT" 58 | , "PGUSER" 59 | , "PGPASS" 60 | , "PGDATABASE" 61 | ] 62 | prodStr <- mconcat . zipWith (<>) keys . fmap BS.pack 63 | <$> traverse (MaybeT . lookupEnv) envs 64 | runStdoutLoggingT $ createPostgresqlPool prodStr (envPool Production) 65 | case pool of 66 | Nothing -> error "Database Configuration not present in environment." 67 | Just a -> return a 68 | 69 | envPool :: Environment -> Int 70 | envPool Test = 1 71 | envPool Development = 1 72 | envPool Production = 8 73 | 74 | connStr :: Environment -> ConnectionString 75 | connStr _ = "host=localhost dbname=quicklift user=test password=test port=5432" 76 | -------------------------------------------------------------------------------- /src/Models.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | {-# LANGUAGE EmptyDataDecls #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE GADTs #-} 6 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 7 | {-# LANGUAGE MultiParamTypeClasses #-} 8 | {-# LANGUAGE OverloadedStrings #-} 9 | {-# LANGUAGE QuasiQuotes #-} 10 | {-# LANGUAGE RankNTypes #-} 11 | {-# LANGUAGE RecordWildCards #-} 12 | {-# LANGUAGE TemplateHaskell #-} 13 | {-# LANGUAGE TypeFamilies #-} 14 | 15 | module Models where 16 | 17 | import Control.Monad.Logger (runStderrLoggingT) 18 | import Control.Monad.Reader 19 | import Control.Monad.Trans.Control 20 | import Data.Aeson 21 | import Data.Aeson.TH 22 | import Data.Char (toLower) 23 | import Data.Text (Text ()) 24 | import Data.Time 25 | import Database.Persist.Postgresql 26 | import Database.Persist.TH 27 | import GHC.Generics 28 | import Web.Users.Persistent 29 | import Web.Users.Types 30 | 31 | import Config 32 | 33 | share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| 34 | Liftsession json 35 | text Text 36 | date UTCTime 37 | user LoginId 38 | deriving Show 39 | 40 | Profile json 41 | user LoginId 42 | deriving Show 43 | |] 44 | 45 | data Registration 46 | = Registration 47 | { regName :: Text 48 | , regEmail :: Text 49 | , regPassword :: Text 50 | , regConfirmation :: Text 51 | } deriving (Eq, Show) 52 | 53 | deriveJSON defaultOptions { fieldLabelModifier = map toLower . Prelude.drop 3, constructorTagModifier = map toLower } ''Registration 54 | 55 | data Auth 56 | = Auth 57 | { authEmail :: Text 58 | , authPassword :: Text 59 | } deriving (Eq, Show) 60 | 61 | deriveJSON defaultOptions { fieldLabelModifier = map toLower . Prelude.drop 4, constructorTagModifier = map toLower } ''Auth 62 | 63 | doMigrations :: ReaderT SqlBackend IO () 64 | doMigrations = runMigration migrateAll 65 | 66 | runDb :: (MonadIO m, MonadReader Config m) => SqlPersistT IO b -> m b 67 | runDb query = asks getPool >>= liftIO . runSqlPool query 68 | 69 | db :: (MonadIO m, MonadBaseControl IO m) => SqlPersistM a -> m a 70 | db query = 71 | runStderrLoggingT . 72 | withPostgresqlPool (connStr Development) 1 $ 73 | liftIO . runSqlPersistMPool query 74 | 75 | 76 | data Person = Person 77 | { name :: Text 78 | , email :: Text 79 | , personId :: LoginId 80 | } deriving (Eq, Show, Generic) 81 | 82 | instance ToJSON Person 83 | instance FromJSON Person 84 | 85 | type QLUser = User UserDetails 86 | type UserDetails = () 87 | 88 | userToPerson :: LoginId -> QLUser -> Person 89 | userToPerson lid User {..} = 90 | Person { name = u_name 91 | , email = u_email 92 | , personId = lid 93 | } 94 | 95 | convertRegistration :: Registration -> QLUser 96 | convertRegistration Registration{..} = 97 | User { u_name = regName 98 | , u_email = regEmail 99 | , u_password = makePassword . PasswordPlain $ regPassword 100 | , u_more = () 101 | , u_active = True 102 | } 103 | 104 | 105 | data AuthResponse 106 | = AuthResponse 107 | { sessionId :: SessionId 108 | , person :: Person 109 | } deriving (Eq, Show, Generic) 110 | 111 | instance ToJSON AuthResponse 112 | -------------------------------------------------------------------------------- /src/Parser.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | 3 | module Parser where 4 | 5 | import Control.Lens 6 | import Control.Monad.Loops 7 | import Data.List (genericReplicate) 8 | import Data.Scientific 9 | import Data.Text (Text) 10 | import qualified Data.Text as T 11 | import Text.Megaparsec as M 12 | import qualified Text.Megaparsec.Lexer as L 13 | 14 | data Lift 15 | = Lift 16 | { _name :: Text 17 | , _setList :: [Set] 18 | } deriving (Eq, Show) 19 | 20 | data Set 21 | = Set 22 | { _weight :: Scientific 23 | , _reps :: Integer 24 | } deriving (Eq, Show) 25 | 26 | makeLenses ''Lift 27 | makeLenses ''Set 28 | 29 | data Session = Session [Lift] deriving (Eq, Show) 30 | 31 | parse :: Parsec Text a -> String -> Text -> Either ParseError a 32 | parse = M.parse 33 | 34 | session :: Parsec Text Session 35 | session = Session <$> liftParser `sepBy` eol 36 | 37 | liftParser :: Parsec Text Lift 38 | liftParser = Lift <$> liftName <*> liftSets 39 | 40 | liftName :: Parsec Text Text 41 | liftName = T.pack <$> (space' *> someTill anyChar (char ':') <* space) 42 | 43 | liftSets :: Parsec Text [Set] 44 | liftSets = concat <$> setLine `sepEndBy` eol 45 | 46 | setLine :: Parsec Text [Set] 47 | setLine = do 48 | weight' <- decimal "weight" 49 | firstOff <- repsxsets 50 | reps'repeats <- unfoldWhileM (/= (1, 1)) repsxsets 51 | let sets' = firstOff : reps'repeats >>= uncurry (flip genericReplicate) 52 | return . fmap (Set weight') $ sets' 53 | 54 | repsxsets :: Parsec Text (Integer, Integer) 55 | repsxsets = do 56 | reps_ <- xThenInt "reps" 57 | repeats <- xThenInt <* skipComma "repeats" 58 | return (reps_, repeats) 59 | 60 | xThenInt :: Parsec Text Integer 61 | xThenInt = option 1 $ (space' >> skipChar 'x' >> integer) 62 | 63 | lexeme :: Parsec Text a -> Parsec Text a 64 | lexeme = L.lexeme space' 65 | 66 | comma :: Parsec Text Char 67 | comma = lexeme (char ',') 68 | 69 | decimal :: Parsec Text Scientific 70 | decimal = either (`scientific` 0) fromFloatDigits <$> number 71 | 72 | float :: Parsec Text Double 73 | float = lexeme L.float 74 | 75 | number :: Parsec Text (Either Integer Double) 76 | number = lexeme L.number 77 | 78 | integer :: Parsec Text Integer 79 | integer = lexeme L.integer 80 | 81 | skipChar :: Char -> Parsec Text () 82 | skipChar = lexeme . skipMany . char' 83 | 84 | skipComma :: Parsec Text () 85 | skipComma = skipChar ',' 86 | 87 | space' :: Parsec Text () 88 | space' = skipMany (oneOf " \t") 89 | -------------------------------------------------------------------------------- /src/Server.hs: -------------------------------------------------------------------------------- 1 | module Server where 2 | 3 | import Control.Monad (liftM) 4 | import Database.Persist.Postgresql (runSqlPool) 5 | import Network.Wai.Handler.Warp (run) 6 | import Network.Wai.Middleware.Gzip 7 | import Web.Users.Persistent (Persistent (..)) 8 | import Web.Users.Types (initUserBackend) 9 | 10 | import Api (app) 11 | import Config (Config (..), Environment (..), 12 | defaultConfig, makePool, 13 | setLogger) 14 | import Models (doMigrations) 15 | import Util 16 | 17 | 18 | quickLift :: IO () 19 | quickLift = do 20 | env <- lookupSetting "ENV" Development 21 | port <- lookupSetting "PORT" 8081 22 | pool <- makePool env 23 | let cfg = defaultConfig { getPool = pool, getEnv = env } 24 | logger = setLogger env 25 | middlewares = gzip def { gzipFiles = GzipCompress } . logger 26 | runSqlPool doMigrations pool 27 | initUserBackend (Persistent (`runSqlPool` pool)) 28 | run port . middlewares $ app cfg 29 | -------------------------------------------------------------------------------- /src/Users.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | {-# LANGUAGE StandaloneDeriving #-} 3 | {-# LANGUAGE TemplateHaskell #-} 4 | 5 | module Users where 6 | 7 | import Control.Monad () 8 | import Control.Monad.Reader 9 | import Data.Aeson.TH 10 | import Data.Int 11 | import Data.Text (Text ()) 12 | import Database.Persist.Postgresql 13 | import GHC.Generics 14 | import qualified Web.Users.Persistent as WU 15 | import qualified Web.Users.Types as WU 16 | 17 | import Config 18 | import Models (QLUser (), UserDetails) 19 | import Users.TH 20 | 21 | backend :: AppM WU.Persistent 22 | backend = do 23 | pool <- asks getPool 24 | return $ WU.Persistent (`runSqlPool` pool) 25 | 26 | 27 | type SessionId = WU.SessionId 28 | 29 | data RegistrationError 30 | = EmailAlreadyTaken 31 | deriving (Show, Generic) 32 | 33 | deriveJSON defaultOptions ''RegistrationError 34 | 35 | deriveReader 'backend 36 | 37 | getUserIdByName :: Text -> AppM (Maybe WU.LoginId) 38 | getUserById :: WU.LoginId -> AppM (Maybe QLUser) 39 | listUsers :: Maybe (Int64, Int64) -> AppM [(WU.LoginId, QLUser)] 40 | countUsers :: AppM Int64 41 | createUser :: QLUser -> AppM (Either WU.CreateUserError WU.LoginId) 42 | updateUser :: WU.LoginId -> (QLUser -> QLUser) -> AppM (Either WU.UpdateUserError ()) 43 | updateUserDetails :: WU.LoginId -> (UserDetails -> UserDetails) -> AppM () 44 | -------------------------------------------------------------------------------- /src/Users/TH.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | 3 | module Users.TH where 4 | 5 | import Control.Monad 6 | import Control.Monad.Reader (liftIO) 7 | import Database.Persist.TH () 8 | 9 | import Language.Haskell.TH 10 | 11 | import Web.Users.Persistent () 12 | import Web.Users.Types 13 | 14 | functionLevels :: Type -> Int 15 | functionLevels = go 0 16 | where 17 | go :: Int -> Type -> Int 18 | go n (AppT (AppT ArrowT _) rest) = go (n+1) rest 19 | go n (ForallT _ _ rest) = go n rest 20 | go n _ = n 21 | 22 | 23 | getType :: Info -> Maybe Type 24 | getType (ClassOpI _ t _ _) = Just t 25 | getType (DataConI _ t _ _) = Just t 26 | getType (VarI _ t _ _) = Just t 27 | getType (TyVarI _ t) = Just t 28 | getType _ = Nothing 29 | 30 | 31 | deriveReader :: Name -> DecsQ 32 | deriveReader rd = 33 | mapM (decForFunc rd) 34 | [ 'destroyUserBackend 35 | , 'housekeepBackend 36 | , 'getUserIdByName 37 | , 'getUserById 38 | , 'listUsers 39 | , 'countUsers 40 | , 'verifySession 41 | , 'createUser 42 | , 'updateUser 43 | , 'updateUserDetails 44 | , 'authUser 45 | , 'deleteUser 46 | ] 47 | 48 | decForFunc :: Name -> Name -> Q Dec 49 | decForFunc reader fn = do 50 | info <- reify fn 51 | arity <- maybe (reportError "Unable to get arity of name" >> return 0) 52 | (return . functionLevels) 53 | (getType info) 54 | varNames <- replicateM (arity - 1) (newName "arg") 55 | b <- newName "b" 56 | let fnName = mkName . nameBase $ fn 57 | bound = AppE (VarE '(>>=)) (VarE reader) 58 | binder = AppE bound . LamE [VarP b] 59 | varExprs = map VarE (b : varNames) 60 | fullExpr = foldl AppE (VarE fn) varExprs 61 | liftedExpr = AppE (VarE 'liftIO) fullExpr 62 | final = binder liftedExpr 63 | varPat = map VarP varNames 64 | return $ FunD fnName [Clause varPat (NormalB final) []] 65 | -------------------------------------------------------------------------------- /src/Util.hs: -------------------------------------------------------------------------------- 1 | module Util where 2 | 3 | import System.Environment (lookupEnv) 4 | 5 | lookupSetting :: Read a => String -> a -> IO a 6 | lookupSetting env def = maybe def read <$> lookupEnv env 7 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | flags: {} 2 | packages: 3 | - '.' 4 | extra-deps: 5 | - 'servant-0.5' 6 | - 'servant-server-0.5' 7 | resolver: lts-5.8 8 | -------------------------------------------------------------------------------- /test/ParserSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE QuasiQuotes #-} 3 | {-# LANGUAGE TemplateHaskell #-} 4 | 5 | module ParserSpec where 6 | 7 | import Data.Scientific 8 | import Test.Hspec 9 | import Text.QuasiText 10 | import Data.Either 11 | import Parser 12 | 13 | spec :: Spec 14 | spec = do 15 | describe "liftName" $ do 16 | let p = parse liftName "" 17 | it "parses a lift name" $ do 18 | p "Squat:" `shouldBe` Right "Squat" 19 | p " Squat: \n" `shouldBe` Right "Squat" 20 | it "requires a ':' to indicate end of name" $ do 21 | p "Squat" `shouldSatisfy` isLeft 22 | describe "setLine" $ do 23 | let p = parse setLine "" 24 | it "parses a set line only weight" $ do 25 | p "100" `shouldBe` 26 | Right [Set 100 1] 27 | it "parses a set with reps" $ do 28 | p "100 x 10" `shouldBe` 29 | Right [Set 100 10] 30 | it "repeats a set" $ do 31 | p "100 x 10 x 2" `shouldBe` 32 | Right (replicate 2 (Set 100 10)) 33 | it "can work with commas" $ do 34 | p "100 x 10, 5" `shouldBe` 35 | Right [Set 100 10, Set 100 5] 36 | it "can work with commas and sets" $ do 37 | p "100 x 10 x 2, 5" `shouldBe` 38 | Right [Set 100 10, Set 100 10, Set 100 5] 39 | p "100 x 10 x 2, 5 x 2" `shouldBe` 40 | Right [Set 100 10, Set 100 10, Set 100 5, Set 100 5] 41 | describe "decimal" $ do 42 | let p = parse decimal "" 43 | it "parses ints" $ do 44 | p "10" `shouldBe` Right (scientific 10 0) 45 | it "parses floats" $ do 46 | p "10.5" `shouldBe` Right (scientific 105 (-1)) 47 | p "10.25" `shouldBe` Right (scientific 1025 (-2)) 48 | describe "xThenInt" $ do 49 | let p = parse xThenInt "" 50 | it "Skips an optional x" $ do 51 | p "10" `shouldBe` Right 10 52 | it "succeeds with an x" $ do 53 | p "x10" `shouldBe` Right 10 54 | it "doesn't care about spaces" $ do 55 | p " x 10" `shouldBe` Right 10 56 | it "defaults to 1" $ do 57 | p "" `shouldBe` Right 1 58 | describe "repsxsets" $ do 59 | let p = parse repsxsets "" 60 | it "parses full format correctly" $ do 61 | p "10 x 10" `shouldBe` Right (10, 10) 62 | it "parses missing sets correctly" $ do 63 | p "10" `shouldBe` Right (10, 1) 64 | it "parses blank as (1, 1)" $ do 65 | p "" `shouldBe` Right (1, 1) 66 | 67 | describe "liftSets" $ do 68 | let p = parse liftSets "" 69 | it "parses many lift sets" $ do 70 | let s = [embed| 71 | 10 72 | 10 x 2 73 | 10 x 2 x 3 74 | |] 75 | p s `shouldBe` 76 | Right [Set 10 1, Set 10 2, Set 10 2, Set 10 2, Set 10 2] 77 | 78 | describe "session" $ do 79 | let p = parse session "" 80 | ex = Lift "Squat" [ Set 100 1, Set 110 2, Set 115 3, 81 | Set 115 3, Set 115 3, Set 100 8, Set 100 5, Set 82 | 102.5 3, Set 102.5 3, Set 102.5 3, Set 102.5 5] 83 | it "parses an empty lift" $ do 84 | p "" `shouldBe` Right (Session []) 85 | it "parses a single set" $ do 86 | p "Squat: 100" `shouldBe` Right (Session [Lift "Squat" [Set 100 1]]) 87 | it "is good with a newline" $ do 88 | p "Squat:\n100" `shouldBe` Right (Session [Lift "Squat" [Set 100 1]]) 89 | it "parses a single lift" $ do 90 | let s = [embed| 91 | Squat: 92 | 100 93 | 110 x 2 94 | 115 x 3 x 3 95 | 100 x 8, 5 96 | 102.5 x 3 x 3, 5 97 | 98 | |] 99 | p s `shouldBe` Right (Session [ex]) 100 | it "parses two lifts" $ do 101 | let s = [embed| 102 | Squat: 103 | 100 104 | 105 | Squat: 106 | 100 107 | |] 108 | p s `shouldBe` Right (Session (replicate 2 (Lift "Squat" [Set 100 1]))) 109 | -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} 2 | 3 | --module Main where 4 | -- 5 | --import Test.Hspec 6 | -- 7 | --main :: IO () 8 | --main = hspec $ do 9 | -- describe "trivial" $ do 10 | -- it "should be true" $ do 11 | -- True `shouldBe` True 12 | --------------------------------------------------------------------------------