├── hastory-cli ├── test │ ├── Spec.hs │ ├── Hastory │ │ └── Cli │ │ │ ├── Commands │ │ │ ├── GenGatherWrapperSpec.hs │ │ │ ├── RegisterSpec.hs │ │ │ ├── SuggestionSpec.hs │ │ │ └── SyncSpec.hs │ │ │ ├── OptParse │ │ │ └── TypesSpec.hs │ │ │ └── OptParseSpec.hs │ └── TestImport.hs ├── Setup.hs ├── LICENSE ├── app │ └── Main.hs ├── bench │ ├── Import.hs │ └── Main.hs ├── src │ └── Hastory │ │ ├── Cli │ │ ├── Utils.hs │ │ ├── Commands │ │ │ ├── GenGatherWrapper.hs │ │ │ ├── GenChangeWrapper.hs │ │ │ ├── ChangeDir.hs │ │ │ ├── ListDir.hs │ │ │ ├── Register.hs │ │ │ ├── Gather.hs │ │ │ ├── SuggestAlias.hs │ │ │ ├── Recent.hs │ │ │ └── Sync.hs │ │ ├── Internal.hs │ │ ├── OptParse │ │ │ └── Types.hs │ │ └── OptParse.hs │ │ └── Cli.hs ├── package.yaml └── hastory-cli.cabal ├── hastory-data-gen ├── test │ ├── Spec.hs │ ├── Hastory │ │ └── InstanceSpec.hs │ └── TestImport.hs ├── LICENSE ├── bench │ ├── Import.hs │ └── Main.hs ├── src │ └── Hastory │ │ └── Gen.hs ├── package.yaml └── hastory-data-gen.cabal ├── hastory-data ├── src │ └── Hastory │ │ ├── Data.hs │ │ └── Data │ │ ├── Password.hs │ │ ├── AuthCookie.hs │ │ ├── Path.hs │ │ ├── UserForm.hs │ │ ├── PasswordDifficulty.hs │ │ ├── SyncRequest.hs │ │ ├── Client │ │ └── DB.hs │ │ ├── Server │ │ └── DB.hs │ │ ├── Username.hs │ │ └── Digest.hs ├── Setup.hs ├── LICENSE ├── package.yaml └── hastory-data.cabal ├── hastory-server ├── test │ ├── Spec.hs │ └── Hastory │ │ ├── Handler │ │ ├── SessionsSpec.hs │ │ ├── UsersSpec.hs │ │ └── EntriesSpec.hs │ │ └── OptParseSpec.hs ├── Setup.hs ├── src │ └── Hastory │ │ ├── Server │ │ ├── Handler.hs │ │ ├── Handler │ │ │ ├── Import.hs │ │ │ ├── Sessions.hs │ │ │ ├── Entries.hs │ │ │ └── Users.hs │ │ ├── HastoryHandler.hs │ │ ├── Utils.hs │ │ ├── TestUtils.hs │ │ └── OptParse.hs │ │ └── Server.hs ├── LICENSE ├── app │ └── Main.hs ├── package.yaml └── hastory-server.cabal ├── hastory-api ├── Setup.hs ├── LICENSE ├── src │ └── Hastory │ │ ├── API │ │ ├── Gather.hs │ │ └── Utils.hs │ │ └── API.hs ├── package.yaml └── hastory-api.cabal ├── .hindent.yaml ├── default.nix ├── scripts ├── redo.sh └── devel.sh ├── .github ├── FUNDING.yml └── workflows │ └── nix-build.yml ├── nix ├── nixpkgs-version.nix ├── validity-version.nix ├── nixpkgs.nix ├── gitignore-src.nix ├── pkgs.nix ├── pre-commit.nix ├── nixos-module-test.nix ├── nixos-module.nix ├── overlay.nix └── home-manager-module.nix ├── .gitignore ├── ci.nix ├── .hlint.yaml ├── shell.nix ├── LICENSE ├── TODO.smos ├── stack.yaml └── README.md /hastory-cli/test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} 2 | -------------------------------------------------------------------------------- /hastory-data-gen/test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} 2 | -------------------------------------------------------------------------------- /hastory-data/src/Hastory/Data.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF autoexporter #-} 2 | -------------------------------------------------------------------------------- /hastory-server/test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} 2 | -------------------------------------------------------------------------------- /hastory-api/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | 3 | main = defaultMain 4 | -------------------------------------------------------------------------------- /hastory-cli/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | 3 | main = defaultMain 4 | -------------------------------------------------------------------------------- /hastory-data/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | 3 | main = defaultMain 4 | -------------------------------------------------------------------------------- /hastory-server/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | 3 | main = defaultMain 4 | -------------------------------------------------------------------------------- /.hindent.yaml: -------------------------------------------------------------------------------- 1 | indent-size: 2 2 | line-length: 100 3 | force-trailing-newline: true 4 | -------------------------------------------------------------------------------- /default.nix: -------------------------------------------------------------------------------- 1 | let 2 | pkgs = import ./nix/pkgs.nix; 3 | in 4 | pkgs.hastoryPackages 5 | -------------------------------------------------------------------------------- /scripts/redo.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | set -ex 4 | 5 | hastory-server serve & 6 | -------------------------------------------------------------------------------- /hastory-api/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Tom Sydney Kerckhove (c) 2016 2 | 3 | All rights reserved. 4 | -------------------------------------------------------------------------------- /hastory-cli/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Tom Sydney Kerckhove (c) 2016 2 | 3 | All rights reserved. 4 | -------------------------------------------------------------------------------- /hastory-server/src/Hastory/Server/Handler.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF autoexporter #-} 2 | -------------------------------------------------------------------------------- /hastory-data-gen/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Tom Sydney Kerckhove (c) 2017 2 | 3 | All rights reserved. 4 | -------------------------------------------------------------------------------- /hastory-data/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Tom Sydney Kerckhove (c) 2020 2 | 3 | All rights reserved. 4 | -------------------------------------------------------------------------------- /hastory-server/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Tom Sydney Kerckhove (c) 2016 2 | 3 | All rights reserved. 4 | -------------------------------------------------------------------------------- /.github/FUNDING.yml: -------------------------------------------------------------------------------- 1 | patreon: NorfairKing 2 | liberapay: NorfairKing 3 | custom: https://cs-syd.eu/support 4 | -------------------------------------------------------------------------------- /hastory-cli/app/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Hastory.Cli 4 | 5 | main :: IO () 6 | main = hastoryCli 7 | -------------------------------------------------------------------------------- /hastory-server/app/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Hastory.Server 4 | 5 | main :: IO () 6 | main = hastoryServer 7 | -------------------------------------------------------------------------------- /scripts/devel.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | set -ex 4 | 5 | stack install :hastory-server --file-watch --exec='./scripts/redo.sh' 6 | -------------------------------------------------------------------------------- /hastory-cli/bench/Import.hs: -------------------------------------------------------------------------------- 1 | module Import 2 | ( module X, 3 | ) 4 | where 5 | 6 | import Path as X 7 | import Path.IO as X 8 | import Prelude as X 9 | -------------------------------------------------------------------------------- /hastory-data-gen/bench/Import.hs: -------------------------------------------------------------------------------- 1 | module Import 2 | ( module X, 3 | ) 4 | where 5 | 6 | import Path as X 7 | import Path.IO as X 8 | import Prelude as X 9 | -------------------------------------------------------------------------------- /nix/nixpkgs-version.nix: -------------------------------------------------------------------------------- 1 | { 2 | rev = "e3a2247046d4de66b9b193a6ab3ff040fa3da86d"; 3 | sha256 = "sha256:0gnpspk2lhwjfmkim416az7q3p5rjbc7q5pvhq23j4gbgkhs0q6i"; 4 | } 5 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work/ 2 | *.prof 3 | result* 4 | *.html 5 | *.css 6 | *.js 7 | *.sqlite3 8 | .tool-versions 9 | stack.yaml.lock 10 | notes.txt 11 | .pre-commit-config.yaml 12 | -------------------------------------------------------------------------------- /ci.nix: -------------------------------------------------------------------------------- 1 | let 2 | pkgs = import ./nix/pkgs.nix; 3 | pre-commit-hooks = import ./nix/pre-commit.nix; 4 | in 5 | pkgs.hastoryPackages // { 6 | pre-commit-hooks = pre-commit-hooks.run; 7 | } 8 | -------------------------------------------------------------------------------- /nix/validity-version.nix: -------------------------------------------------------------------------------- 1 | { 2 | owner = "NorfairKing"; 3 | repo = "validity"; 4 | rev = "c38fc635f98580548f82314504e9f8742519f94d"; 5 | sha256 = "sha256:106q361wj8aspggvdj319jny6j6rfdmljha912sf8mdbsxl2gp5i"; 6 | } 7 | -------------------------------------------------------------------------------- /.hlint.yaml: -------------------------------------------------------------------------------- 1 | # HLint configuration file 2 | # https://github.com/ndmitchell/hlint 3 | # https://github.com/ndmitchell/hlint/blob/master/data/default.yaml 4 | ########################## 5 | 6 | - ignore: {name: "Reduce duplication"} 7 | -------------------------------------------------------------------------------- /nix/nixpkgs.nix: -------------------------------------------------------------------------------- 1 | let 2 | nixpkgsVersion = import ./nixpkgs-version.nix; 3 | in 4 | builtins.fetchTarball { 5 | url = 6 | "https://github.com/NixOS/nixpkgs/archive/${nixpkgsVersion.rev}.tar.gz"; 7 | inherit (nixpkgsVersion) sha256; 8 | } 9 | -------------------------------------------------------------------------------- /hastory-data-gen/test/Hastory/InstanceSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeApplications #-} 2 | 3 | module Hastory.InstanceSpec 4 | ( spec, 5 | ) 6 | where 7 | 8 | import Hastory.Data.Client.DB 9 | import Hastory.Gen () 10 | import TestImport 11 | 12 | spec :: Spec 13 | spec = 14 | describe "Entry" $ do 15 | eqSpecOnValid @Entry 16 | arbitrarySpec @Entry 17 | genValidSpec @Entry 18 | -------------------------------------------------------------------------------- /nix/gitignore-src.nix: -------------------------------------------------------------------------------- 1 | final: previous: 2 | let 3 | gitignoreSrc = 4 | final.fetchFromGitHub { 5 | owner = "hercules-ci"; 6 | repo = "gitignore"; 7 | rev = "ec4a0039152655b6c919d289dafd7ba32206ea1f"; 8 | sha256 = "sha256:13qxqbs8jg2mz2fm2cs63czv30gxi39ws5qzf9j8mczqpdj6g3im"; 9 | }; 10 | in 11 | { 12 | inherit (import gitignoreSrc { inherit (final) lib; }) gitignoreSource; 13 | } 14 | -------------------------------------------------------------------------------- /hastory-data/src/Hastory/Data/Password.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-orphans #-} 2 | 3 | module Hastory.Data.Password 4 | ( module Data.Password, 5 | module Data.Password.Bcrypt, 6 | ) 7 | where 8 | 9 | import Data.Password 10 | import Data.Password.Bcrypt hiding (newSalt) 11 | import Data.Password.Instances () 12 | import Data.Validity 13 | 14 | instance Validity Password where 15 | validate = trivialValidation 16 | -------------------------------------------------------------------------------- /hastory-cli/test/Hastory/Cli/Commands/GenGatherWrapperSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Hastory.Cli.Commands.GenGatherWrapperSpec 4 | ( spec, 5 | ) 6 | where 7 | 8 | import Hastory.Cli.Commands.GenGatherWrapper 9 | import Hastory.Cli.OptParse.Types () 10 | import TestImport 11 | 12 | spec :: Spec 13 | spec = describe "genScript" $ it "is a fixed value" $ genScript `shouldContain` "FIRST_PROMPT" 14 | -------------------------------------------------------------------------------- /nix/pkgs.nix: -------------------------------------------------------------------------------- 1 | let 2 | pkgsv = import (import ./nixpkgs.nix); 3 | pkgs = pkgsv {}; 4 | validity-overlay = 5 | import ( 6 | pkgs.fetchFromGitHub (import ./validity-version.nix) + "/nix/overlay.nix" 7 | ); 8 | hastoryPkgs = 9 | pkgsv { 10 | overlays = 11 | [ 12 | validity-overlay 13 | (import ./gitignore-src.nix) 14 | (import ./overlay.nix) 15 | ]; 16 | config.allowUnfree = true; 17 | }; 18 | in 19 | hastoryPkgs 20 | -------------------------------------------------------------------------------- /hastory-cli/src/Hastory/Cli/Utils.hs: -------------------------------------------------------------------------------- 1 | module Hastory.Cli.Utils 2 | ( doCountsWith, 3 | ) 4 | where 5 | 6 | import Data.HashMap.Lazy (HashMap) 7 | import qualified Data.HashMap.Lazy as HM 8 | import Data.Hashable (Hashable) 9 | 10 | doCountsWith :: (Eq b, Hashable b) => (a -> b) -> (a -> Double) -> [a] -> HashMap b Double 11 | doCountsWith conv func = foldl go HM.empty 12 | where 13 | go hm k = HM.alter a (conv k) hm 14 | where 15 | a Nothing = Just 1 16 | a (Just d) = Just $ d + func k 17 | -------------------------------------------------------------------------------- /hastory-data/src/Hastory/Data/AuthCookie.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | 3 | module Hastory.Data.AuthCookie where 4 | 5 | import Data.Aeson 6 | import GHC.Generics (Generic) 7 | import Hastory.Data.Username 8 | import Servant.Auth.Server 9 | 10 | newtype AuthCookie 11 | = AuthCookie 12 | { unAuthCookie :: Username 13 | } 14 | deriving (Generic) 15 | 16 | instance ToJSON AuthCookie 17 | 18 | instance FromJSON AuthCookie 19 | 20 | instance ToJWT AuthCookie 21 | 22 | instance FromJWT AuthCookie 23 | -------------------------------------------------------------------------------- /.github/workflows/nix-build.yml: -------------------------------------------------------------------------------- 1 | name: "Nix Build" 2 | on: 3 | pull_request: 4 | push: 5 | jobs: 6 | tests: 7 | runs-on: ubuntu-latest 8 | steps: 9 | - uses: actions/checkout@v2 10 | - uses: cachix/install-nix-action@v12 11 | - name: free disk space 12 | run: | 13 | sudo rm -rf /opt 14 | - uses: cachix/cachix-action@v8 15 | with: 16 | name: hastory 17 | extraPullNames: validity 18 | signingKey: '${{ secrets.CACHIX_SIGNING_KEY }}' 19 | - run: nix-build ci.nix 20 | -------------------------------------------------------------------------------- /hastory-cli/src/Hastory/Cli/Commands/GenGatherWrapper.hs: -------------------------------------------------------------------------------- 1 | module Hastory.Cli.Commands.GenGatherWrapper where 2 | 3 | genGatherWrapperScript :: IO () 4 | genGatherWrapperScript = putStrLn genScript 5 | 6 | genScript :: String 7 | genScript = 8 | unlines 9 | [ "FIRST_PROMPT=1", 10 | "function hastory_gather_ {", 11 | " AT_PROMPT=1", 12 | " if [[ -n \"$FIRST_PROMPT\" ]]; then", 13 | " unset FIRST_PROMPT", 14 | " return", 15 | " fi", 16 | " echo $(fc -nl $((HISTCMD - 1))) | hastory gather", 17 | "}" 18 | ] 19 | -------------------------------------------------------------------------------- /hastory-cli/src/Hastory/Cli/Commands/GenChangeWrapper.hs: -------------------------------------------------------------------------------- 1 | module Hastory.Cli.Commands.GenChangeWrapper where 2 | 3 | genChangeWrapperScript :: IO () 4 | genChangeWrapperScript = 5 | putStrLn $ 6 | unlines 7 | [ "hastory_change_directory_ () {", 8 | " local args=\"$@\"", 9 | " if [[ \"$args\" == \"\" ]]", 10 | " then", 11 | " hastory list-recent-directories", 12 | " else", 13 | " local dir=$(hastory change-directory \"$args\")", 14 | " cd \"$dir\"", 15 | " fi", 16 | "}" 17 | ] 18 | -------------------------------------------------------------------------------- /hastory-server/src/Hastory/Server/Handler/Import.hs: -------------------------------------------------------------------------------- 1 | module Hastory.Server.Handler.Import 2 | ( module X, 3 | ) 4 | where 5 | 6 | import Control.Monad.Except as X 7 | import Data.Text.Encoding as X (decodeUtf8) 8 | import Data.Validity as X 9 | import Database.Persist as X 10 | import Hastory.API as X 11 | import Hastory.Data as X hiding (Context) 12 | import Hastory.Data.Client.DB as X hiding (migrateAll) 13 | import Hastory.Data.Server.DB as X hiding (migrateAll) 14 | import Hastory.Server.HastoryHandler as X 15 | import Hastory.Server.Utils as X 16 | import Servant.API as X hiding (BasicAuth) 17 | import Servant.Server as X 18 | -------------------------------------------------------------------------------- /nix/pre-commit.nix: -------------------------------------------------------------------------------- 1 | let 2 | pre-commit-hooks = import ( 3 | builtins.fetchTarball { 4 | url = "https://github.com/hercules-ci/nix-pre-commit-hooks/archive/f709c4652d4696dbe7c6a8354ebd5938f2bf807b.tar.gz"; 5 | sha256 = "sha256:0700c5awc2gjzgikhx69vjbpyshx6b5xljmpxrdzpgqyg3blxbkl"; 6 | } 7 | ); 8 | in 9 | { 10 | run = pre-commit-hooks.run { 11 | src = ../.; 12 | hooks = { 13 | nixpkgs-fmt.enable = true; 14 | hlint.enable = true; 15 | ormolu.enable = true; 16 | }; 17 | }; 18 | tools = [ 19 | pre-commit-hooks.hlint 20 | pre-commit-hooks.nixpkgs-fmt 21 | pre-commit-hooks.ormolu 22 | ]; 23 | } 24 | -------------------------------------------------------------------------------- /hastory-data-gen/bench/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | module Main where 5 | 6 | import Criterion.Main as Criterion 7 | import Criterion.Types as Criterion 8 | import Data.GenValidity 9 | import Hastory.API.Gather 10 | import Hastory.Data.Client.DB 11 | import Hastory.Gen () 12 | import Test.QuickCheck 13 | 14 | main :: IO () 15 | main = 16 | let config = Criterion.defaultConfig {Criterion.reportFile = Just "bench.html"} 17 | in Criterion.defaultMainWith 18 | config 19 | [ bench "generate-valid-entry" $ nfIO $ generate (genValid :: Gen Entry), 20 | bench "gather" $ nfIO $ gatherEntryWith "ls -lr" 21 | ] 22 | -------------------------------------------------------------------------------- /hastory-server/src/Hastory/Server/Handler/Sessions.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | 3 | module Hastory.Server.Handler.Sessions where 4 | 5 | import Hastory.Server.Handler.Import 6 | 7 | createSessionHandler :: UserForm -> HastoryHandler (Headers AuthCookies NoContent) 8 | createSessionHandler UserForm {..} = 9 | withUser userFormUserName $ \(Entity _ user) -> 10 | case checkPassword (mkPassword userFormPassword) (userHashedPassword user) of 11 | PasswordCheckSuccess -> setLoggedIn 12 | PasswordCheckFail -> unAuthenticated 13 | where 14 | setLoggedIn = 15 | withSetCookie userFormUserName $ \setCookie -> 16 | pure $ addHeader (decodeUtf8 setCookie) NoContent 17 | -------------------------------------------------------------------------------- /hastory-cli/src/Hastory/Cli/Commands/ChangeDir.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE RecordWildCards #-} 4 | 5 | module Hastory.Cli.Commands.ChangeDir where 6 | 7 | import Control.Monad.IO.Unlift (MonadUnliftIO) 8 | import Control.Monad.Reader 9 | import Hastory.Cli.Commands.Recent 10 | import Hastory.Cli.OptParse.Types 11 | import Safe (atMay) 12 | import System.Exit (die) 13 | 14 | change :: (MonadReader Settings m, MonadUnliftIO m) => ChangeDirSettings -> m () 15 | change ChangeDirSettings {..} = do 16 | recentDirOpts <- getRecentDirOpts False 17 | liftIO $ 18 | case recentDirOpts `atMay` changeDirSetIdx of 19 | Nothing -> die "Invalid index choice." 20 | Just d -> putStrLn d 21 | -------------------------------------------------------------------------------- /hastory-data-gen/test/TestImport.hs: -------------------------------------------------------------------------------- 1 | module TestImport 2 | ( module X, 3 | ) 4 | where 5 | 6 | import Control.Monad as X 7 | import Data.GenValidity as X 8 | import Data.GenValidity.Path as X () 9 | import Data.GenValidity.Text as X () 10 | import Data.GenValidity.Time as X () 11 | import Data.List as X 12 | import Data.Maybe as X 13 | import Data.Monoid as X 14 | import Data.Validity.Path as X () 15 | import Data.Validity.Text as X () 16 | import GHC.Generics as X (Generic) 17 | import Path as X 18 | import Path.IO as X 19 | import System.Exit as X 20 | import Test.Hspec as X 21 | import Test.QuickCheck as X 22 | import Test.Validity as X 23 | import Test.Validity.Aeson as X 24 | import Prelude as X hiding (appendFile, putStr, putStrLn, readFile, writeFile) 25 | -------------------------------------------------------------------------------- /hastory-cli/test/TestImport.hs: -------------------------------------------------------------------------------- 1 | module TestImport 2 | ( module X, 3 | ) 4 | where 5 | 6 | import Control.Monad as X 7 | import Data.GenValidity as X 8 | import Data.GenValidity.Path as X () 9 | import Data.GenValidity.Text as X () 10 | import Data.GenValidity.Time as X () 11 | import Data.List as X 12 | import Data.Maybe as X 13 | import Data.Monoid as X 14 | import Data.Validity.Path as X () 15 | import Data.Validity.Text as X () 16 | import GHC.Generics as X (Generic) 17 | import Hastory.Cli.OptParse.Types as X 18 | import Path as X 19 | import Path.IO as X 20 | import System.Exit as X 21 | import Test.Hspec as X 22 | import Test.QuickCheck as X 23 | import Test.Validity as X 24 | import Test.Validity.Aeson as X 25 | import Prelude as X hiding (appendFile, putStr, putStrLn, readFile, writeFile) 26 | -------------------------------------------------------------------------------- /hastory-api/src/Hastory/API/Gather.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | 3 | module Hastory.API.Gather 4 | ( gatherEntryWith, 5 | ) 6 | where 7 | 8 | import Data.Text (Text) 9 | import qualified Data.Text as T 10 | import qualified Data.Time as Time 11 | import Hastory.Data.Client.DB (Entry (..)) 12 | import Path.IO (getCurrentDir) 13 | import System.Posix.User (getEffectiveUserName) 14 | 15 | gatherEntryWith :: Text -> IO Entry 16 | gatherEntryWith text = do 17 | curtime <- Time.getCurrentTime 18 | curdir <- getCurrentDir 19 | user <- getEffectiveUserName 20 | pure 21 | Entry 22 | { entryText = text, 23 | entryDateTime = curtime, 24 | entryWorkingDir = curdir, 25 | entryUser = T.pack user, 26 | entrySyncWitness = Nothing, 27 | entryHostName = Nothing 28 | } 29 | -------------------------------------------------------------------------------- /hastory-cli/src/Hastory/Cli/Commands/ListDir.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE RecordWildCards #-} 3 | 4 | module Hastory.Cli.Commands.ListDir where 5 | 6 | import Control.Monad.IO.Unlift (MonadUnliftIO) 7 | import Control.Monad.Reader 8 | import Hastory.Cli.Commands.Recent 9 | import Hastory.Cli.OptParse.Types 10 | 11 | listRecentDirs :: (MonadReader Settings m, MonadUnliftIO m) => ListRecentDirSettings -> m () 12 | listRecentDirs ListRecentDirSettings {..} = do 13 | recentDirOpts <- getRecentDirOpts lrdSetBypassCache 14 | let tups = zip [0 ..] recentDirOpts 15 | maxlen = maximum $ map (length . show . fst) tups 16 | formatTup :: Int -> String -> String 17 | formatTup i s = show i ++ replicate (maxlen - length (show i) + 1) ' ' ++ s 18 | liftIO $ forM_ tups $ putStrLn . uncurry formatTup 19 | -------------------------------------------------------------------------------- /hastory-data/src/Hastory/Data/Path.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# OPTIONS_GHC -fno-warn-orphans #-} 4 | 5 | module Hastory.Data.Path 6 | ( module Path, 7 | ) 8 | where 9 | 10 | import Data.Text (unpack) 11 | import Database.Persist (PersistField (..), PersistValue (..)) 12 | import Database.Persist.Sqlite (PersistFieldSql (..), SqlType (..)) 13 | import Path 14 | 15 | instance PersistField (Path Abs Dir) where 16 | toPersistValue = toPersistValue . toFilePath 17 | fromPersistValue (PersistText t) = 18 | case parseAbsDir (unpack t) of 19 | Left _ -> Left "Unable to marshall Path" 20 | Right p -> Right p 21 | fromPersistValue _ = Left "Path must be marshalled from PersistText" 22 | 23 | instance PersistFieldSql (Path Abs Dir) where 24 | sqlType _ = SqlString 25 | -------------------------------------------------------------------------------- /hastory-cli/test/Hastory/Cli/Commands/RegisterSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE RecordWildCards #-} 3 | 4 | module Hastory.Cli.Commands.RegisterSpec 5 | ( spec, 6 | ) 7 | where 8 | 9 | import Hastory.Cli.Commands.Register 10 | import Hastory.Data.Server.DB 11 | import Hastory.Data.Username 12 | import Hastory.Server.TestUtils 13 | import Servant.Client 14 | import TestImport 15 | 16 | spec :: Spec 17 | spec = 18 | serverSpec 19 | $ describe "register" 20 | $ it "creates a user on the server" 21 | $ \ServerInfo {..} -> do 22 | let username = Username "steven" 23 | let remoteInfo = RemoteStorage (baseUrl siClientEnv) username "Passw0rd" 24 | _ <- register (RegisterSettings remoteInfo) 25 | serverUsers <- runSqlPool (selectList [] []) siPool 26 | map (userName . entityVal) serverUsers `shouldBe` [username] 27 | -------------------------------------------------------------------------------- /hastory-data/src/Hastory/Data/UserForm.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | module Hastory.Data.UserForm where 5 | 6 | import Data.Aeson 7 | import Data.Text (Text) 8 | import Data.Validity 9 | import Data.Validity.Text () 10 | import GHC.Generics 11 | import Hastory.Data.Username 12 | 13 | data UserForm 14 | = UserForm 15 | { userFormUserName :: Username, 16 | userFormPassword :: Text 17 | } 18 | deriving (Show, Generic) 19 | 20 | instance FromJSON UserForm where 21 | parseJSON = withObject "UserForm" $ \v -> UserForm <$> v .: "userName" <*> v .: "password" 22 | 23 | instance ToJSON UserForm where 24 | toJSON userForm = 25 | object ["userName" .= userFormUserName userForm, "password" .= userFormPassword userForm] 26 | 27 | instance Validity UserForm where 28 | validate = delve "userFormUserName" . userFormUserName 29 | -------------------------------------------------------------------------------- /hastory-server/src/Hastory/Server/HastoryHandler.hs: -------------------------------------------------------------------------------- 1 | module Hastory.Server.HastoryHandler 2 | ( module Hastory.Server.HastoryHandler, 3 | module Control.Monad.Reader, 4 | ) 5 | where 6 | 7 | import Control.Monad.Reader 8 | import Data.Pool 9 | import Database.Persist.Sql 10 | import Hastory.Data.PasswordDifficulty 11 | import Servant 12 | import Servant.Auth.Server 13 | 14 | type HastoryHandler = ReaderT ServerSettings Handler 15 | 16 | data ServerSettings 17 | = ServerSettings 18 | { serverSetPool :: Pool SqlBackend, 19 | serverSetJWTSettings :: JWTSettings, 20 | serverSetCookieSettings :: CookieSettings, 21 | serverSetPwDifficulty :: PasswordDifficulty 22 | } 23 | 24 | type Query a = ReaderT SqlBackend IO a 25 | 26 | runDB :: Query a -> HastoryHandler a 27 | runDB query = do 28 | pool <- asks serverSetPool 29 | liftIO $ runSqlPool query pool 30 | 31 | unAuthenticated :: HastoryHandler a 32 | unAuthenticated = throwError err401 33 | -------------------------------------------------------------------------------- /hastory-data/src/Hastory/Data/PasswordDifficulty.hs: -------------------------------------------------------------------------------- 1 | module Hastory.Data.PasswordDifficulty 2 | ( PasswordDifficulty, 3 | unPasswordDifficulty, 4 | mkPasswordDifficultyWithError, 5 | passwordDifficultyOrExit, 6 | ) 7 | where 8 | 9 | import Data.Validity 10 | import System.Exit (die) 11 | 12 | instance Validity PasswordDifficulty where 13 | validate (PasswordDifficulty n) = 14 | mconcat 15 | [ declare "Is greater than or equal to 4" (n >= 4), 16 | declare "Is less than or equal to 31" (n <= 31) 17 | ] 18 | 19 | newtype PasswordDifficulty 20 | = PasswordDifficulty 21 | { unPasswordDifficulty :: Int 22 | } 23 | 24 | mkPasswordDifficultyWithError :: Int -> Either String PasswordDifficulty 25 | mkPasswordDifficultyWithError = prettyValidate . PasswordDifficulty 26 | 27 | passwordDifficultyOrExit :: Int -> IO PasswordDifficulty 28 | passwordDifficultyOrExit n = 29 | case mkPasswordDifficultyWithError n of 30 | Right pwDifficulty -> pure pwDifficulty 31 | Left err -> die err 32 | -------------------------------------------------------------------------------- /hastory-server/src/Hastory/Server/Handler/Entries.hs: -------------------------------------------------------------------------------- 1 | module Hastory.Server.Handler.Entries 2 | ( createEntryHandler, 3 | ) 4 | where 5 | 6 | import Hastory.Server.Handler.Import 7 | 8 | createEntryHandler :: AuthCookie -> SyncRequest -> HastoryHandler [Entity ServerEntry] 9 | createEntryHandler cookie syncReq = 10 | withUser (unAuthCookie cookie) $ \user -> do 11 | _ <- insertNewEntries user syncReq 12 | fetchEntriesGreaterThan user (syncRequestLogPosition syncReq) 13 | 14 | insertNewEntries :: Entity User -> SyncRequest -> HastoryHandler [Entity ServerEntry] 15 | insertNewEntries user syncReq = do 16 | let serverEntries = toServerEntries syncReq (entityKey user) 17 | forM serverEntries $ \serverEntry -> runDB $ upsert serverEntry [] -- make no update if record exists 18 | 19 | fetchEntriesGreaterThan :: Entity User -> ServerEntryId -> HastoryHandler [Entity ServerEntry] 20 | fetchEntriesGreaterThan user logPosition = runDB query 21 | where 22 | query = selectList filters [] 23 | filters = [ServerEntryId >. logPosition, ServerEntryUser ==. entityKey user] 24 | -------------------------------------------------------------------------------- /hastory-server/src/Hastory/Server/Handler/Users.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE RecordWildCards #-} 3 | {-# OPTIONS_GHC -fno-warn-orphans #-} 4 | 5 | module Hastory.Server.Handler.Users where 6 | 7 | import qualified Data.ByteString.Lazy.Char8 as C 8 | import Hastory.Data.PasswordDifficulty 9 | import Hastory.Server.Handler.Import 10 | 11 | createUserHandler :: UserForm -> HastoryHandler UserId 12 | createUserHandler userForm@UserForm {..} = do 13 | mUser <- runDB . getBy $ UniqueUsername userFormUserName 14 | case mUser of 15 | Nothing -> either respondWithErr buildAndInsertUser (prettyValidate userForm) 16 | Just _ -> throwError err400 17 | where 18 | respondWithErr err = throwError $ err400 {errBody = C.pack err} 19 | 20 | buildAndInsertUser :: UserForm -> HastoryHandler UserId 21 | buildAndInsertUser UserForm {..} = do 22 | difficulty <- asks (unPasswordDifficulty . serverSetPwDifficulty) 23 | user <- 24 | User userFormUserName 25 | <$> liftIO (hashPasswordWithParams difficulty . mkPassword $ userFormPassword) 26 | runDB $ insert user 27 | -------------------------------------------------------------------------------- /hastory-cli/src/Hastory/Cli/Commands/Register.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | 3 | module Hastory.Cli.Commands.Register 4 | ( register, 5 | ) 6 | where 7 | 8 | import Control.Monad.IO.Unlift (MonadUnliftIO, liftIO) 9 | import Hastory.API 10 | import Hastory.Cli.OptParse.Types 11 | import Hastory.Data.UserForm 12 | import Network.HTTP.Client 13 | import Network.HTTP.Conduit (tlsManagerSettings) 14 | import Servant.Client hiding (client, manager) 15 | import System.Exit 16 | 17 | register :: MonadUnliftIO m => RegisterSettings -> m () 18 | register (RegisterSettings RemoteStorage {..}) = 19 | liftIO $ do 20 | client <- mkClient 21 | resp <- runHastoryClient (createUserClient userForm) client 22 | case resp of 23 | Left clientError -> die $ "Register command failed. Error: " ++ show clientError 24 | Right _userId -> putStrLn "Registration succeeded" 25 | where 26 | userForm = UserForm remoteStorageUsername remoteStoragePassword 27 | mkClient = acceptManager <$> newManager tlsManagerSettings 28 | acceptManager = flip mkClientEnv remoteStorageBaseUrl 29 | -------------------------------------------------------------------------------- /shell.nix: -------------------------------------------------------------------------------- 1 | let 2 | pkgs = import ./nix/pkgs.nix; 3 | pre-commit-hooks = import ./nix/pre-commit.nix; 4 | in 5 | pkgs.mkShell { 6 | name = "smos-nix-shell"; 7 | buildInputs = pre-commit-hooks.tools; 8 | shellHook = '' 9 | ${pre-commit-hooks.run.shellHook} 10 | 11 | 12 | function nix-build_ { 13 | nix-build \ 14 | --option extra-substituters https://iohk.cachix.org \ 15 | --option trusted-public-keys iohk.cachix.org-1:DpRUyj7h7V830dp/i6Nti+NEO2/nhblbov/8MW7Rqoo= \ 16 | --option extra-substituters https://validity.cachix.org \ 17 | --option trusted-public-keys validity.cachix.org-1:CqZp6vt9ir3yB5f8GAtfkJxPZG8hKC5fhIdaQsf7eZE= \ 18 | --option extra-substituters https://yamlparse.cachix.org \ 19 | --option trusted-public-keys yamlparse.cachix.org-1:DLkIYUWCK4HdTen7mwYsf2LB8o+REcV73MONfnAtQsY= \ 20 | --option extra-substituters https://smos.cachix.org \ 21 | --option trusted-public-keys smos.cachix.org-1:YOs/tLEliRoyhx7PnNw36cw2Zvbw5R0ASZaUlpUv+yM= \ 22 | $* 23 | } 24 | alias nix-build=nix-build_ 25 | ''; 26 | } 27 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2019 Tom Kerckhove 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. -------------------------------------------------------------------------------- /hastory-cli/src/Hastory/Cli/Commands/Gather.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE RecordWildCards #-} 3 | 4 | module Hastory.Cli.Commands.Gather where 5 | 6 | import Control.Monad.IO.Unlift (MonadUnliftIO) 7 | import Control.Monad.Reader 8 | import Data.Text (Text) 9 | import qualified Data.Text.IO as T 10 | import Database.Persist.Sqlite (Entity, upsertBy) 11 | import Hastory.API.Gather 12 | import Hastory.Cli.Internal 13 | import Hastory.Cli.OptParse.Types 14 | import Hastory.Data.Client.DB 15 | 16 | gather :: (MonadReader Settings m, MonadUnliftIO m) => m (Entity Entry) 17 | gather = do 18 | text <- liftIO T.getContents 19 | gatherFrom text 20 | 21 | gatherFrom :: (MonadReader Settings m, MonadUnliftIO m) => Text -> m (Entity Entry) 22 | gatherFrom text = do 23 | entry <- liftIO $ gatherEntryWith text 24 | storeHistory entry 25 | 26 | storeHistory :: (MonadReader Settings m, MonadUnliftIO m) => Entry -> m (Entity Entry) 27 | storeHistory entry@Entry {..} = runDb (upsertBy uniqueRecord entry noUpdate) 28 | where 29 | uniqueRecord = EntryData entryText entryWorkingDir entryDateTime entryUser 30 | noUpdate = [] 31 | -------------------------------------------------------------------------------- /hastory-cli/test/Hastory/Cli/Commands/SuggestionSpec.hs: -------------------------------------------------------------------------------- 1 | module Hastory.Cli.Commands.SuggestionSpec 2 | ( spec, 3 | ) 4 | where 5 | 6 | import qualified Data.Text as T 7 | import Hastory.Cli.Commands.SuggestAlias 8 | import Hastory.Data.Client.DB 9 | import Hastory.Gen () 10 | import Safe (tailSafe) 11 | import Test.Validity 12 | import TestImport 13 | 14 | spec :: Spec 15 | spec = do 16 | describe "commandPrefixes" $ do 17 | it "lists only prefixes of the command, ignoring whitespace" $ forAllValid $ \e -> 18 | map T.concat (commandPrefixes e) 19 | `shouldSatisfy` all (`T.isPrefixOf` T.concat (T.words $ entryText e)) 20 | it "contains only nonempty prefixes" $ forAllValid $ \e -> 21 | commandPrefixes e `shouldSatisfy` all (\p -> not $ null p || any T.null p) 22 | describe "aggregateSuggestions" $ do 23 | it "counts each command exactly once" $ forAllValid $ \es -> 24 | sum (map (round . snd) (aggregateSuggestions (es :: [T.Text]))) `shouldBe` length es 25 | it "is sorted by nonincreasing frequency" $ forAllValid $ \es -> 26 | map snd (aggregateSuggestions (es :: [T.Text])) `shouldSatisfy` and 27 | . (zipWith (>=) <*> tailSafe) 28 | -------------------------------------------------------------------------------- /hastory-data/package.yaml: -------------------------------------------------------------------------------- 1 | name: hastory-data 2 | version: 0.0.0.0 3 | homepage: https://github.com/NorfairKing/hastory 4 | license: AllRightsReserved 5 | author: Tom Sydney Kerckhove 6 | maintainer: syd.kerckhove@gmail.com 7 | copyright: 2020 Tom Sydney Kerckhove 8 | category: Command Line 9 | 10 | dependencies: 11 | - base >=4.9 && <=5 12 | 13 | library: 14 | source-dirs: src/ 15 | dependencies: 16 | - aeson 17 | - base64 18 | - bytestring 19 | - cryptonite 20 | - deepseq 21 | - genvalidity-path 22 | - genvalidity-text 23 | - genvalidity-time 24 | - hostname 25 | - memory 26 | - password 27 | - password-instances 28 | - path 29 | - persistent 30 | - persistent-sqlite 31 | - persistent-template 32 | - servant-auth-server 33 | - text 34 | - time 35 | - validity 36 | - validity-text 37 | ghc-options: 38 | - -Wall 39 | - -Wcompat 40 | - -Widentities 41 | - -Wincomplete-record-updates 42 | - -Wincomplete-uni-patterns 43 | - -Wpartial-fields 44 | - -Wredundant-constraints 45 | - -fhide-source-paths 46 | -------------------------------------------------------------------------------- /TODO.smos: -------------------------------------------------------------------------------- 1 | - header: Use sqlite instead of json for hastory-server 2 | state-history: 3 | - state: DONE 4 | time: 2020-11-09 12:40:00.384181042000 5 | - state: TODO 6 | time: 2019-09-10 13:52:01.274802781000 7 | - header: Hastory server to store logs from multiple sources 8 | state-history: 9 | - state: DONE 10 | time: 2020-11-09 12:40:06.120199199000 11 | - state: TODO 12 | time: 2018-11-17 18:28:43.829842454000 13 | - entry: 14 | header: Alias Suggestions 15 | state-history: 16 | - state: TODO 17 | time: 2018-11-17 18:28:45.048446873000 18 | forest: 19 | - header: Better define what it means for an alias to be 'a good idea' 20 | contents: |- 21 | For example, 'l' is probably not a great thing to alias because 22 | it is most likely already an alias. 23 | state-history: 24 | - state: TODO 25 | time: 2018-11-17 18:28:45.048446873000 26 | - header: Add a flag that says how many options i want to see 27 | state-history: 28 | - state: TODO 29 | time: 2018-11-17 18:29:18.403654613000 30 | - header: Some command that lists all commands in order of usage 31 | state-history: 32 | - state: TODO 33 | time: 2018-11-17 18:29:37.320873976000 34 | - header: Stats 35 | state-history: 36 | - state: TODO 37 | time: 2018-11-17 18:28:44.201328428000 38 | -------------------------------------------------------------------------------- /hastory-data/src/Hastory/Data/SyncRequest.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE RecordWildCards #-} 4 | {-# OPTIONS_GHC -Wno-orphans #-} 5 | 6 | module Hastory.Data.SyncRequest where 7 | 8 | import Data.Aeson 9 | import Data.Text 10 | import qualified Data.Text as T 11 | import Data.Validity 12 | import GHC.Generics (Generic) 13 | import Hastory.Data.Client.DB (Entry (..)) 14 | import Hastory.Data.Server.DB (ServerEntryId) 15 | import Network.HostName (HostName) 16 | 17 | data SyncRequest 18 | = SyncRequest 19 | { syncRequestEntries :: [Entry], 20 | syncRequestHostName :: Text, 21 | syncRequestLogPosition :: ServerEntryId 22 | } 23 | deriving (Show, Eq, Generic) 24 | 25 | instance ToJSON SyncRequest 26 | 27 | instance FromJSON SyncRequest 28 | 29 | instance Validity ServerEntryId where 30 | validate = trivialValidation 31 | 32 | instance Validity SyncRequest where 33 | validate SyncRequest {..} = 34 | mconcat 35 | [ delve "entries" syncRequestEntries, 36 | check (T.length syncRequestHostName > 0) "hostname is at least one char", 37 | delve "log position" syncRequestLogPosition 38 | ] 39 | 40 | toSyncRequest :: [Entry] -> HostName -> ServerEntryId -> SyncRequest 41 | toSyncRequest entries hostName = SyncRequest entries (T.pack hostName) 42 | -------------------------------------------------------------------------------- /hastory-data/src/Hastory/Data/Client/DB.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | {-# LANGUAGE DerivingStrategies #-} 3 | {-# LANGUAGE GADTs #-} 4 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | {-# LANGUAGE QuasiQuotes #-} 7 | {-# LANGUAGE StandaloneDeriving #-} 8 | {-# LANGUAGE TemplateHaskell #-} 9 | {-# LANGUAGE TypeFamilies #-} 10 | {-# LANGUAGE UndecidableInstances #-} 11 | 12 | module Hastory.Data.Client.DB where 13 | 14 | import Control.DeepSeq 15 | import Data.Aeson 16 | import Data.GenValidity.Path () 17 | import Data.GenValidity.Text () 18 | import Data.GenValidity.Time () 19 | import Data.Int 20 | import Data.Text (Text) 21 | import Data.Time (UTCTime) 22 | import Data.Validity (Validity) 23 | import Database.Persist.TH (mkMigrate, mkPersist, persistLowerCase, share, sqlSettings) 24 | import GHC.Generics (Generic) 25 | import Hastory.Data.Path 26 | 27 | share 28 | [mkPersist sqlSettings, mkMigrate "migrateAll"] 29 | [persistLowerCase| 30 | Entry 31 | text Text 32 | workingDir (Path Abs Dir) 33 | dateTime UTCTime 34 | user Text 35 | syncWitness Int64 Maybe 36 | EntryData text workingDir dateTime user 37 | hostName Text Maybe 38 | deriving Show Eq Generic 39 | |] 40 | 41 | instance Validity Entry 42 | 43 | instance NFData Entry 44 | 45 | instance ToJSON Entry 46 | 47 | instance FromJSON Entry 48 | -------------------------------------------------------------------------------- /hastory-api/package.yaml: -------------------------------------------------------------------------------- 1 | name: hastory-api 2 | version: '0.0.0.0' 3 | category: Command Line 4 | author: Tom Sydney Kerckhove 5 | maintainer: syd.kerckhove@gmail.com 6 | copyright: ! 'Copyright: (c) 2016-2018 Tom Sydney Kerckhove' 7 | license: AllRightsReserved 8 | homepage: https://github.com/NorfairKing/hastory 9 | 10 | dependencies: 11 | - base >=4.9 && <=5 12 | 13 | 14 | library: 15 | source-dirs: src/ 16 | ghc-options: 17 | - -Wall 18 | - -Wincomplete-uni-patterns 19 | - -Wincomplete-record-updates 20 | - -Wredundant-constraints 21 | 22 | dependencies: 23 | - aeson 24 | - conduit 25 | - cookie 26 | - deepseq 27 | - exceptions 28 | - genvalidity 29 | - genvalidity-path 30 | - genvalidity-text 31 | - genvalidity-time 32 | - hashable 33 | - hashable-time 34 | - hastory-data 35 | - hostname 36 | - hspec 37 | - http-client 38 | - http-conduit 39 | - lifted-base 40 | - monad-control 41 | - monad-logger 42 | - mtl 43 | - path 44 | - path-io 45 | - persistent 46 | - persistent-sqlite 47 | - persistent-template 48 | - safe 49 | - servant 50 | - servant-auth-client 51 | - servant-auth-server 52 | - servant-client 53 | - servant-client-core 54 | - servant-server 55 | - text 56 | - time 57 | - unix 58 | - unordered-containers 59 | - validity 60 | - validity-path 61 | - validity-text 62 | - validity-time 63 | -------------------------------------------------------------------------------- /hastory-api/src/Hastory/API/Utils.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Hastory.API.Utils 4 | ( doCountsWith, 5 | dataBaseSpec, 6 | runDb, 7 | ) 8 | where 9 | 10 | import Conduit (MonadUnliftIO) 11 | import Control.Monad.IO.Class (liftIO) 12 | import Control.Monad.Logger (runNoLoggingT) 13 | import Control.Monad.Reader (ReaderT) 14 | import Data.HashMap.Lazy (HashMap) 15 | import qualified Data.HashMap.Lazy as HM 16 | import Data.Hashable (Hashable) 17 | import Database.Persist.Sqlite (SqlBackend, runMigrationSilent, runSqlConn, withSqliteConn) 18 | import Hastory.Data.Client.DB (migrateAll) 19 | import Test.Hspec (ActionWith, Spec, SpecWith, around) 20 | 21 | doCountsWith :: (Eq b, Hashable b) => (a -> b) -> (a -> Double) -> [a] -> HashMap b Double 22 | doCountsWith conv func = foldl go HM.empty 23 | where 24 | go hm k = HM.alter a (conv k) hm 25 | where 26 | a Nothing = Just 1 27 | a (Just d) = Just $ d + func k 28 | 29 | dataBaseSpec :: SpecWith SqlBackend -> Spec 30 | dataBaseSpec = around withDatabase 31 | 32 | withDatabase :: ActionWith SqlBackend -> IO () 33 | withDatabase func = 34 | runNoLoggingT 35 | $ withSqliteConn ":memory:" 36 | $ \conn -> do 37 | _ <- runDb conn (runMigrationSilent migrateAll) 38 | liftIO $ func conn 39 | 40 | runDb :: (MonadUnliftIO m) => SqlBackend -> ReaderT SqlBackend m a -> m a 41 | runDb = flip runSqlConn 42 | -------------------------------------------------------------------------------- /hastory-data/src/Hastory/Data/Server/DB.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | {-# LANGUAGE DerivingStrategies #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE GADTs #-} 5 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 6 | {-# LANGUAGE InstanceSigs #-} 7 | {-# LANGUAGE MultiParamTypeClasses #-} 8 | {-# LANGUAGE OverloadedStrings #-} 9 | {-# LANGUAGE QuasiQuotes #-} 10 | {-# LANGUAGE StandaloneDeriving #-} 11 | {-# LANGUAGE TemplateHaskell #-} 12 | {-# LANGUAGE TypeFamilies #-} 13 | {-# LANGUAGE UndecidableInstances #-} 14 | {-# OPTIONS_GHC -fno-warn-orphans #-} 15 | 16 | module Hastory.Data.Server.DB where 17 | 18 | import Data.Text (Text) 19 | import Data.Time (UTCTime) 20 | import Database.Persist.TH (mkMigrate, mkPersist, persistLowerCase, share, sqlSettings) 21 | import GHC.Generics (Generic) 22 | import Hastory.Data.Digest 23 | import Hastory.Data.Password 24 | import Hastory.Data.Path 25 | import Hastory.Data.Username 26 | 27 | share 28 | [mkPersist sqlSettings, mkMigrate "migrateAll"] 29 | [persistLowerCase| 30 | 31 | User 32 | name Username 33 | hashedPassword (PasswordHash Bcrypt) 34 | UniqueUsername name 35 | 36 | ServerEntry json 37 | user UserId 38 | text Text 39 | workingDir (Path Abs Dir) 40 | dateTime UTCTime 41 | hostUser Text 42 | hostName Text 43 | contentHash (Digest SHA256) 44 | UniqueContentHash contentHash 45 | deriving Show Eq Generic 46 | 47 | |] 48 | -------------------------------------------------------------------------------- /hastory-server/test/Hastory/Handler/SessionsSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE RecordWildCards #-} 3 | 4 | module Hastory.Handler.SessionsSpec 5 | ( spec, 6 | ) 7 | where 8 | 9 | import Data.Either 10 | import Hastory.API 11 | import Hastory.Data 12 | import Hastory.Gen () 13 | import Hastory.Server.TestUtils 14 | import Servant.Client 15 | import Test.Hspec 16 | import Test.Validity 17 | 18 | spec :: Spec 19 | spec = 20 | serverSpec 21 | $ describe "POST /sessions" 22 | $ do 23 | context "incorrect login" 24 | $ it "is a 401" 25 | $ \ServerInfo {..} -> 26 | forAllValid $ \userForm -> do 27 | Right _ <- runClientM (createUserClient userForm) siClientEnv 28 | let incorrectPasswordForm = 29 | userForm {userFormPassword = "badPrefix" <> userFormPassword userForm} 30 | Left (FailureResponse _requestF resp) <- 31 | runClientM (createSessionClient incorrectPasswordForm) siClientEnv 32 | responseStatusCode resp `shouldBe` status401 33 | context "correct login" 34 | $ it "returns a cookie" 35 | $ \ServerInfo {..} -> 36 | forAllValid $ \userForm -> do 37 | Right _ <- runClientM (createUserClient userForm) siClientEnv 38 | Right resp <- runClientM (createSessionClient userForm) siClientEnv 39 | extractJWTCookie resp `shouldSatisfy` isRight 40 | -------------------------------------------------------------------------------- /hastory-cli/src/Hastory/Cli.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | 3 | module Hastory.Cli 4 | ( hastoryCli, 5 | ) 6 | where 7 | 8 | import Control.Monad.IO.Unlift (MonadUnliftIO) 9 | import Control.Monad.Reader 10 | import Hastory.Cli.Commands.ChangeDir (change) 11 | import Hastory.Cli.Commands.Gather (gather) 12 | import Hastory.Cli.Commands.GenChangeWrapper (genChangeWrapperScript) 13 | import Hastory.Cli.Commands.GenGatherWrapper (genGatherWrapperScript) 14 | import Hastory.Cli.Commands.ListDir (listRecentDirs) 15 | import Hastory.Cli.Commands.Register (register) 16 | import Hastory.Cli.Commands.SuggestAlias (suggest) 17 | import Hastory.Cli.Commands.Sync (sync) 18 | import Hastory.Cli.OptParse 19 | 20 | hastoryCli :: IO () 21 | hastoryCli = do 22 | Instructions d sets <- getInstructions 23 | runReaderT (dispatch d) sets 24 | 25 | dispatch :: (MonadReader Settings m, MonadUnliftIO m) => Dispatch -> m () 26 | dispatch (DispatchGather _) = void gather 27 | dispatch (DispatchGenGatherWrapperScript _) = liftIO genGatherWrapperScript 28 | dispatch (DispatchChangeDir changeDirSettings) = change changeDirSettings 29 | dispatch (DispatchListRecentDirs lrds) = listRecentDirs lrds 30 | dispatch (DispatchGenChangeWrapperScript _) = liftIO genChangeWrapperScript 31 | dispatch (DispatchSuggestAlias _) = suggest 32 | dispatch (DispatchSync syncSettings) = sync syncSettings 33 | dispatch (DispatchRegister registerSettings) = register registerSettings 34 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-15.15 2 | packages: 3 | - hastory-api 4 | - hastory-cli 5 | - hastory-data 6 | - hastory-data-gen 7 | - hastory-server 8 | extra-deps: 9 | - base64-0.4.2 10 | - ghc-byteorder-4.11.0.0.10 11 | - password-2.0.1.1 12 | - password-instances-2.0.0.1 13 | - servant-auth-client-0.4.0.0 14 | - yamlparse-applicative-0.1.0.1 15 | - github: supki/envparse 16 | commit: de5944fb09e9d941fafa35c0f05446af348e7b4d 17 | - github: NorfairKing/validity 18 | commit: c38fc635f98580548f82314504e9f8742519f94d 19 | subdirs: 20 | - genvalidity 21 | - genvalidity-aeson 22 | - genvalidity-bytestring 23 | - genvalidity-containers 24 | - genvalidity-criterion 25 | - genvalidity-hspec 26 | - genvalidity-hspec-aeson 27 | - genvalidity-hspec-binary 28 | - genvalidity-hspec-cereal 29 | - genvalidity-hspec-hashable 30 | - genvalidity-hspec-optics 31 | - genvalidity-path 32 | - genvalidity-property 33 | - genvalidity-scientific 34 | - genvalidity-text 35 | - genvalidity-time 36 | - genvalidity-unordered-containers 37 | - genvalidity-uuid 38 | - genvalidity-vector 39 | - validity 40 | - validity-aeson 41 | - validity-bytestring 42 | - validity-containers 43 | - validity-path 44 | - validity-primitive 45 | - validity-scientific 46 | - validity-text 47 | - validity-time 48 | - validity-unordered-containers 49 | - validity-uuid 50 | - validity-vector 51 | nix: 52 | path: [ "nixpkgs=https://github.com/NixOS/nixpkgs/archive/e3a2247046d4de66b9b193a6ab3ff040fa3da86d.tar.gz" ] 53 | add-gc-roots: true 54 | packages: 55 | - haskellPackages.autoexporter 56 | - killall 57 | - zlib 58 | -------------------------------------------------------------------------------- /hastory-cli/src/Hastory/Cli/Commands/SuggestAlias.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | 3 | module Hastory.Cli.Commands.SuggestAlias where 4 | 5 | import Control.Arrow ((***)) 6 | import Control.Monad.IO.Unlift (MonadUnliftIO) 7 | import Control.Monad.Reader 8 | import qualified Data.HashMap.Lazy as HM 9 | import Data.Hashable (Hashable) 10 | import Data.List (inits, sortOn) 11 | import Data.Ord (Down (..)) 12 | import Data.Text (Text) 13 | import qualified Data.Text as T 14 | import Hastory.Cli.Internal 15 | import Hastory.Cli.OptParse.Types 16 | import Hastory.Cli.Utils (doCountsWith) 17 | import Hastory.Data.Client.DB 18 | import Safe (tailSafe) 19 | 20 | suggest :: (MonadReader Settings m, MonadUnliftIO m) => m () 21 | suggest = do 22 | rawEnts <- getLastNDaysOfHistory 7 23 | let tups = take 10 $ suggestions rawEnts 24 | let maxlen = maximum $ map (length . show . snd) tups 25 | formatTup (t, x) = 26 | show x ++ replicate (maxlen - length (show x) + 1) ' ' ++ T.unpack (T.strip t) 27 | liftIO $ forM_ tups $ putStrLn . formatTup 28 | 29 | suggestions :: [Entry] -> [(Text, Integer)] 30 | suggestions rawEnts = map (T.unwords *** round) tups 31 | where 32 | entries = filter (not . isCDEntry) rawEnts 33 | prefixes = [w | e <- entries, w <- commandPrefixes e] 34 | tups = aggregateSuggestions prefixes 35 | 36 | isCDEntry :: Entry -> Bool 37 | isCDEntry = T.isPrefixOf (T.pack "cd ") . entryText 38 | 39 | -- tailSafe drops the empty string 40 | commandPrefixes :: Entry -> [[Text]] 41 | commandPrefixes = tailSafe . inits . T.words . entryText 42 | 43 | aggregateSuggestions :: (Eq a, Hashable a) => [a] -> [(a, Double)] 44 | aggregateSuggestions = sortOn (Down . snd) . HM.toList . doCountsWith id (const 1.0) 45 | -------------------------------------------------------------------------------- /hastory-data-gen/src/Hastory/Gen.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# OPTIONS_GHC -Wno-orphans #-} 3 | 4 | module Hastory.Gen where 5 | 6 | import Control.Applicative 7 | import Data.GenValidity 8 | import Data.GenValidity.Text 9 | import qualified Data.Text as T 10 | import Database.Persist.Sql (fromSqlKey, toSqlKey) 11 | import Hastory.Data 12 | import Hastory.Data.Client.DB 13 | import Hastory.Data.Server.DB 14 | import Test.QuickCheck 15 | 16 | instance GenValid Entry where 17 | genValid = genValidStructurally 18 | shrinkValid = shrinkValidStructurally 19 | 20 | instance Arbitrary Entry where 21 | arbitrary = genValid 22 | shrink = shrinkValidStructurally 23 | 24 | instance GenValid Password where 25 | genValid = mkPassword <$> genValid 26 | shrinkValid _ = [] -- don't shrink Password 27 | 28 | instance GenValid ServerEntryId where 29 | genValid = toSqlKey <$> genValid 30 | shrinkValid = map toSqlKey . shrinkValid . fromSqlKey 31 | 32 | instance GenValid SyncRequest where 33 | genValid = genValidStructurallyWithoutExtraChecking 34 | shrinkValid = shrinkValidStructurally 35 | 36 | instance GenValid UserForm where 37 | genValid = genValidStructurally 38 | shrinkValid = shrinkValidStructurally 39 | 40 | instance GenValid Username where 41 | genValid = Username <$> userNameTextGen 42 | where 43 | userNameTextGen = liftA2 (<>) lengthThreeText arbitraryLengthText 44 | lengthThreeText = T.pack <$> vectorOf 3 asciiLetterOrDigitGen 45 | arbitraryLengthText = genTextBy asciiLetterOrDigitGen 46 | asciiLetterOrDigitGen = oneof [asciiUppercaseGen, asciiLowercaseGen, asciiDigitGen] 47 | asciiDigitGen = choose ('0', '9') 48 | asciiUppercaseGen = choose ('A', 'Z') 49 | asciiLowercaseGen = choose ('a', 'z') 50 | shrinkValid = shrinkValidStructurally 51 | -------------------------------------------------------------------------------- /hastory-data/src/Hastory/Data/Username.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | {-# LANGUAGE DerivingStrategies #-} 3 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 4 | {-# LANGUAGE OverloadedStrings #-} 5 | 6 | module Hastory.Data.Username where 7 | 8 | import qualified Control.Monad.Fail as Fail 9 | import Data.Aeson (FromJSON (parseJSON), ToJSON (toJSON), withText) 10 | import Data.Char 11 | import Data.Text (Text) 12 | import qualified Data.Text as T 13 | import Data.Validity 14 | import Database.Persist.Sql (PersistField, PersistFieldSql) 15 | import GHC.Generics 16 | 17 | newtype Username 18 | = Username 19 | { usernameText :: Text 20 | } 21 | deriving (Eq, Generic) 22 | deriving newtype (Show, PersistField, PersistFieldSql) 23 | 24 | instance FromJSON Username where 25 | parseJSON = withText "Username" $ pure . Username 26 | 27 | instance ToJSON Username where 28 | toJSON = toJSON . usernameText 29 | 30 | instance Validity Username where 31 | validate userName = 32 | mconcat 33 | [check (userNameLength > 2) "Username length is greater than two", allAsciiLetterOrDigit] 34 | where 35 | userNameLength = T.length . usernameText $ userName 36 | allAsciiLetterOrDigit = decorateList (T.unpack . usernameText $ userName) asciiLetterOrDigit 37 | asciiLetterOrDigit c = 38 | mconcat 39 | [ check (isAscii c) "Char is ASCII", 40 | check (isDigit c || isLetter c) "Char is letter or digit" 41 | ] 42 | 43 | parseUsername :: MonadFail m => Text -> m Username 44 | parseUsername input = 45 | case parseUsernameWithError input of 46 | Left err -> Fail.fail err 47 | Right validatedUsername -> pure validatedUsername 48 | 49 | parseUsernameWithError :: Text -> Either String Username 50 | parseUsernameWithError = prettyValidate . Username 51 | -------------------------------------------------------------------------------- /hastory-data-gen/package.yaml: -------------------------------------------------------------------------------- 1 | name: hastory-data-gen 2 | version: '0.0.0.0' 3 | category: Command Line 4 | author: Tom Sydney Kerckhove 5 | maintainer: syd.kerckhove@gmail.com 6 | copyright: ! 'Copyright: (c) 2017-2018 Tom Sydney Kerckhove' 7 | license: AllRightsReserved 8 | homepage: https://github.com/NorfairKing/hastory 9 | 10 | dependencies: 11 | - hastory-data 12 | - path 13 | - path-io 14 | 15 | library: 16 | source-dirs: src/ 17 | ghc-options: -Wall 18 | dependencies: 19 | - base >=4.9 && <=5 20 | - QuickCheck 21 | - genvalidity 22 | - genvalidity-hspec 23 | - genvalidity-hspec-aeson 24 | - genvalidity-path 25 | - genvalidity-text 26 | - genvalidity-time 27 | - hspec 28 | - persistent 29 | - text 30 | - validity 31 | - validity-path 32 | - validity-text 33 | 34 | tests: 35 | hastory-data-test: 36 | main: Spec.hs 37 | source-dirs: test/ 38 | default-extensions: 39 | - NoImplicitPrelude 40 | ghc-options: 41 | - -threaded 42 | - -rtsopts 43 | - -with-rtsopts=-N 44 | - -Wall 45 | dependencies: 46 | - base >=4.9 && <=5 47 | - hastory-data-gen 48 | - genvalidity 49 | - genvalidity-hspec 50 | - genvalidity-path 51 | - genvalidity-text 52 | - genvalidity-time 53 | - genvalidity-hspec-aeson 54 | - hspec 55 | - validity 56 | - validity-path 57 | - validity-text 58 | - QuickCheck 59 | - safe 60 | - text 61 | 62 | benchmarks: 63 | hastory-data-bench: 64 | main: Main.hs 65 | source-dirs: bench 66 | ghc-options: 67 | - -threaded 68 | - -rtsopts 69 | - -with-rtsopts=-T 70 | - -Wall 71 | dependencies: 72 | - QuickCheck 73 | - base 74 | - criterion 75 | - exceptions 76 | - genvalidity 77 | - hastory-api 78 | - hastory-data 79 | - hastory-data-gen 80 | - mtl 81 | -------------------------------------------------------------------------------- /hastory-data/hastory-data.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 1.12 2 | 3 | -- This file has been generated from package.yaml by hpack version 0.33.0. 4 | -- 5 | -- see: https://github.com/sol/hpack 6 | -- 7 | -- hash: beb32647e11acd9206165e2dd22e959a373ab360019d339da9bf40d763ae4f4b 8 | 9 | name: hastory-data 10 | version: 0.0.0.0 11 | category: Command Line 12 | homepage: https://github.com/NorfairKing/hastory 13 | author: Tom Sydney Kerckhove 14 | maintainer: syd.kerckhove@gmail.com 15 | copyright: 2020 Tom Sydney Kerckhove 16 | license: AllRightsReserved 17 | license-file: LICENSE 18 | build-type: Simple 19 | 20 | library 21 | exposed-modules: 22 | Hastory.Data 23 | Hastory.Data.AuthCookie 24 | Hastory.Data.Client.DB 25 | Hastory.Data.Digest 26 | Hastory.Data.Password 27 | Hastory.Data.PasswordDifficulty 28 | Hastory.Data.Path 29 | Hastory.Data.Server.DB 30 | Hastory.Data.SyncRequest 31 | Hastory.Data.UserForm 32 | Hastory.Data.Username 33 | other-modules: 34 | Paths_hastory_data 35 | hs-source-dirs: 36 | src/ 37 | ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -fhide-source-paths 38 | build-depends: 39 | aeson 40 | , base >=4.9 && <=5 41 | , base64 42 | , bytestring 43 | , cryptonite 44 | , deepseq 45 | , genvalidity-path 46 | , genvalidity-text 47 | , genvalidity-time 48 | , hostname 49 | , memory 50 | , password 51 | , password-instances 52 | , path 53 | , persistent 54 | , persistent-sqlite 55 | , persistent-template 56 | , servant-auth-server 57 | , text 58 | , time 59 | , validity 60 | , validity-text 61 | default-language: Haskell2010 62 | -------------------------------------------------------------------------------- /hastory-data/src/Hastory/Data/Digest.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# OPTIONS_GHC -fno-warn-orphans #-} 4 | 5 | module Hastory.Data.Digest 6 | ( module Hastory.Data.Digest, 7 | ) 8 | where 9 | 10 | import Crypto.Hash as Hastory.Data.Digest 11 | import Data.Aeson 12 | import Data.ByteArray (convert) 13 | import qualified Data.ByteArray as BA 14 | import qualified Data.ByteString as B 15 | import qualified Data.ByteString.Base64 as Base64 16 | import Data.Proxy (Proxy (Proxy)) 17 | import qualified Data.Text as T 18 | import qualified Data.Text.Encoding as T 19 | import Database.Persist.Class (PersistField (fromPersistValue, toPersistValue)) 20 | import Database.Persist.Sql (PersistFieldSql (sqlType)) 21 | import Database.Persist.Types (PersistValue (PersistByteString)) 22 | 23 | instance HashAlgorithm a => PersistField (Digest a) where 24 | toPersistValue = toPersistValue . B.pack . BA.unpack 25 | fromPersistValue (PersistByteString rawDigest) = 26 | case digestFromByteString rawDigest of 27 | Nothing -> Left "Unable to reify Digest from ByteString" 28 | Just reifiedDigest -> Right reifiedDigest 29 | fromPersistValue _ = Left "Digest values must be convered from PersistByteString" 30 | 31 | instance HashAlgorithm a => PersistFieldSql (Digest a) where 32 | sqlType _ = sqlType (Proxy :: Proxy B.ByteString) 33 | 34 | instance FromJSON (Digest SHA256) where 35 | parseJSON = 36 | withText "Digest SHA256" $ \text -> 37 | case Base64.decodeBase64 (T.encodeUtf8 text) of 38 | Left err -> fail ("Failed to parse (Digest SHA256): " ++ T.unpack err) 39 | Right bs -> 40 | case digestFromByteString bs of 41 | Nothing -> fail "Failed to parse (Digest SHA256)" 42 | Just digest -> pure digest 43 | 44 | instance ToJSON (Digest SHA256) where 45 | toJSON = toJSON . T.decodeUtf8 . Base64.encodeBase64' . convert 46 | -------------------------------------------------------------------------------- /hastory-api/hastory-api.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 1.12 2 | 3 | -- This file has been generated from package.yaml by hpack version 0.33.0. 4 | -- 5 | -- see: https://github.com/sol/hpack 6 | -- 7 | -- hash: e908d7a580637c20f05f734179f74c0678071a10cd3ea4258fb20b56db9869bd 8 | 9 | name: hastory-api 10 | version: 0.0.0.0 11 | category: Command Line 12 | homepage: https://github.com/NorfairKing/hastory 13 | author: Tom Sydney Kerckhove 14 | maintainer: syd.kerckhove@gmail.com 15 | copyright: Copyright: (c) 2016-2018 Tom Sydney Kerckhove 16 | license: AllRightsReserved 17 | license-file: LICENSE 18 | build-type: Simple 19 | 20 | library 21 | exposed-modules: 22 | Hastory.API 23 | Hastory.API.Gather 24 | Hastory.API.Utils 25 | other-modules: 26 | Paths_hastory_api 27 | hs-source-dirs: 28 | src/ 29 | ghc-options: -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wredundant-constraints 30 | build-depends: 31 | aeson 32 | , base >=4.9 && <=5 33 | , conduit 34 | , cookie 35 | , deepseq 36 | , exceptions 37 | , genvalidity 38 | , genvalidity-path 39 | , genvalidity-text 40 | , genvalidity-time 41 | , hashable 42 | , hashable-time 43 | , hastory-data 44 | , hostname 45 | , hspec 46 | , http-client 47 | , http-conduit 48 | , lifted-base 49 | , monad-control 50 | , monad-logger 51 | , mtl 52 | , path 53 | , path-io 54 | , persistent 55 | , persistent-sqlite 56 | , persistent-template 57 | , safe 58 | , servant 59 | , servant-auth-client 60 | , servant-auth-server 61 | , servant-client 62 | , servant-client-core 63 | , servant-server 64 | , text 65 | , time 66 | , unix 67 | , unordered-containers 68 | , validity 69 | , validity-path 70 | , validity-text 71 | , validity-time 72 | default-language: Haskell2010 73 | -------------------------------------------------------------------------------- /hastory-cli/src/Hastory/Cli/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE TemplateHaskell #-} 4 | 5 | module Hastory.Cli.Internal where 6 | 7 | import Control.Monad.IO.Unlift (MonadUnliftIO) 8 | import Control.Monad.Logger (NoLoggingT) 9 | import Control.Monad.Reader 10 | import Control.Monad.Trans.Resource (ResourceT) 11 | import qualified Data.Text as T 12 | import Data.Time 13 | import Database.Persist.Sqlite (SqlBackend) 14 | import qualified Database.Persist.Sqlite as SQL 15 | import Hastory.Cli.OptParse.Types 16 | import Hastory.Data.Client.DB 17 | import Path 18 | import Path.IO (ensureDir) 19 | import System.Exit 20 | 21 | hastoryDir :: MonadReader Settings m => m (Path Abs Dir) 22 | hastoryDir = asks setDataDir 23 | 24 | histDir :: MonadReader Settings m => m (Path Abs Dir) 25 | histDir = fmap ( $(mkRelDir "command-history")) hastoryDir 26 | 27 | histDb :: (MonadReader Settings m, MonadUnliftIO m) => m (Path Abs File) 28 | histDb = do 29 | hd <- histDir 30 | let filePath = "hastory.db" 31 | case parseRelFile "hastory.db" of 32 | Nothing -> liftIO $ die ("Unable to parse relative file path: " <> filePath) 33 | Just file -> pure $ hd file 34 | 35 | getLastNDaysOfHistory :: (MonadReader Settings m, MonadUnliftIO m) => Integer -> m [Entry] 36 | getLastNDaysOfHistory n = do 37 | currentTime <- liftIO getCurrentTime 38 | let minDateTime = addUTCTime nDaysInPast currentTime 39 | nDaysInPast = negate $ fromInteger (86400 * n) 40 | entries <- runDb $ SQL.selectList [EntryDateTime SQL.>=. minDateTime] [] 41 | pure (SQL.entityVal <$> entries) 42 | 43 | -- | The 'runDb' function should used, at most, once per command invocation. 44 | -- Please refer hastory . 45 | runDb :: 46 | (MonadReader Settings m, MonadUnliftIO m) => 47 | ReaderT SqlBackend (NoLoggingT (ResourceT m)) a -> 48 | m a 49 | runDb dbAction = do 50 | sets <- ask 51 | hDb <- liftIO $ runReaderT histDb sets 52 | ensureDir $ parent hDb 53 | SQL.runSqlite (T.pack . toFilePath $ hDb) $ do 54 | SQL.runMigration migrateAll 55 | dbAction 56 | -------------------------------------------------------------------------------- /hastory-server/test/Hastory/Handler/UsersSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE RecordWildCards #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | 5 | module Hastory.Handler.UsersSpec 6 | ( spec, 7 | ) 8 | where 9 | 10 | import qualified Data.ByteString.Lazy.Char8 as C 11 | import Hastory.API 12 | import Hastory.Data 13 | import Hastory.Data.Server.DB 14 | import Hastory.Gen () 15 | import Hastory.Server.TestUtils 16 | import Servant.Client 17 | import Test.Hspec 18 | import Test.Validity 19 | 20 | spec :: Spec 21 | spec = 22 | serverSpec 23 | $ describe "POST /users" 24 | $ do 25 | context "valid new user request" 26 | $ it "creates the user" 27 | $ \ServerInfo {..} -> 28 | forAllValid $ \userForm -> do 29 | Right _ <- runClientM (createUserClient userForm) siClientEnv 30 | [Entity _ newUser] <- runSqlPool (selectList [] []) siPool 31 | userName newUser `shouldBe` userFormUserName userForm 32 | context "userForm is invalid" $ do 33 | it "does not create the user" $ \ServerInfo {..} -> do 34 | let invalidUserName = 35 | "\192400\440428\904918\344036\355\177961\879579\1046203\470521\1025773" 36 | userForm = UserForm (Username invalidUserName) "Password" 37 | Left (FailureResponse _requestF resp) <- runClientM (createUserClient userForm) siClientEnv 38 | responseStatusCode resp `shouldBe` status400 39 | users <- runSqlPool (selectList [] []) siPool :: IO [Entity User] 40 | length users `shouldBe` 0 41 | it "shows appropriate error message" $ \ServerInfo {..} -> do 42 | let invalidUserName = "\0" 43 | userForm = UserForm (Username invalidUserName) "Password" 44 | Left (FailureResponse _requestF resp) <- runClientM (createUserClient userForm) siClientEnv -- Either ClientError UserId 45 | let errMsg = C.unpack (responseBody resp) 46 | errMsg `shouldContain` "Violated: Char is letter or digit" 47 | context "username already exists" 48 | $ it "is a 400" 49 | $ \ServerInfo {..} -> 50 | forAllValid $ \userForm -> do 51 | Right _ <- runClientM (createUserClient userForm) siClientEnv 52 | Left (FailureResponse _requestF resp) <- 53 | runClientM (createUserClient userForm) siClientEnv 54 | responseStatusCode resp `shouldBe` status400 55 | -------------------------------------------------------------------------------- /hastory-server/src/Hastory/Server/Utils.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | 3 | module Hastory.Server.Utils where 4 | 5 | import Control.Monad.Error.Class 6 | import Data.ByteString (ByteString) 7 | import Data.Text (Text) 8 | import qualified Data.Text as T 9 | import qualified Data.Text.Encoding as T 10 | import Data.Time.Format (defaultTimeLocale, formatTime, iso8601DateFormat) 11 | import Database.Persist 12 | import Hastory.Data 13 | import Hastory.Data.Client.DB 14 | import Hastory.Data.Server.DB 15 | import Hastory.Server.HastoryHandler 16 | import Servant.Auth.Server 17 | import Servant.Server 18 | 19 | withUser :: Username -> (Entity User -> HastoryHandler a) -> HastoryHandler a 20 | withUser username k = do 21 | mUser <- runDB . getBy $ UniqueUsername username 22 | case mUser of 23 | Nothing -> throwError err401 24 | Just entityUser -> k entityUser 25 | 26 | withSetCookie :: Username -> (ByteString -> HastoryHandler a) -> HastoryHandler a 27 | withSetCookie userName func = do 28 | let cookie = AuthCookie userName 29 | cookieSettings <- asks serverSetCookieSettings 30 | jwtSettings <- asks serverSetJWTSettings 31 | mSetCookie <- liftIO (makeSessionCookieBS cookieSettings jwtSettings cookie) 32 | case mSetCookie of 33 | Nothing -> throwError err401 34 | Just bs -> func bs 35 | 36 | hashEntry :: Entry -> T.Text -> Digest SHA256 37 | hashEntry Entry {..} host = hashWith SHA256 (unifiedData :: ByteString) 38 | where 39 | unifiedData = 40 | mconcat 41 | [ T.encodeUtf8 entryText, 42 | hashPrepare $ fromAbsDir entryWorkingDir, 43 | hashPrepare $ formatIso8601 entryDateTime, 44 | T.encodeUtf8 entryUser, 45 | T.encodeUtf8 host 46 | ] 47 | hashPrepare = T.encodeUtf8 . T.pack 48 | formatIso8601 = formatTime defaultTimeLocale formatString 49 | formatString = iso8601DateFormat (Just "%H:%M:%S") 50 | 51 | toServerEntries :: SyncRequest -> UserId -> [ServerEntry] 52 | toServerEntries syncRequest serverEntryUser = 53 | let syncEntries = syncRequestEntries syncRequest 54 | hostName = syncRequestHostName syncRequest 55 | in map (toServerEntry serverEntryUser hostName) syncEntries 56 | 57 | toServerEntry :: UserId -> Text -> Entry -> ServerEntry 58 | toServerEntry serverEntryUser serverEntryHostName entry@Entry {..} = ServerEntry {..} 59 | where 60 | serverEntryText = entryText 61 | serverEntryWorkingDir = entryWorkingDir 62 | serverEntryDateTime = entryDateTime 63 | serverEntryHostUser = entryUser 64 | serverEntryContentHash = hashEntry entry serverEntryHostName 65 | -------------------------------------------------------------------------------- /hastory-server/package.yaml: -------------------------------------------------------------------------------- 1 | name: hastory-server 2 | version: '0.0.0.0' 3 | category: Command Line 4 | author: Tom Sydney Kerckhove 5 | maintainer: syd.kerckhove@gmail.com 6 | copyright: ! 'Copyright: (c) 2016-2018 Tom Sydney Kerckhove' 7 | license: AllRightsReserved 8 | homepage: https://github.com/NorfairKing/hastory 9 | 10 | dependencies: 11 | - base >=4.9 && <=5 12 | ghc-options: 13 | - -Wall 14 | - -Wcompat 15 | - -Widentities 16 | - -Wincomplete-record-updates 17 | - -Wincomplete-uni-patterns 18 | - -Wpartial-fields 19 | - -Wredundant-constraints 20 | - -fhide-source-paths 21 | library: 22 | source-dirs: src/ 23 | dependencies: 24 | - QuickCheck 25 | - aeson 26 | - base 27 | - bytestring 28 | - conduit 29 | - cookie 30 | - cryptonite 31 | - deepseq 32 | - envparse 33 | - exceptions 34 | - hashable 35 | - hashable-time 36 | - hastory-api 37 | - hastory-data 38 | - hostname 39 | - hspec 40 | - http-client 41 | - http-types 42 | - jose 43 | - microlens 44 | - monad-logger 45 | - mtl 46 | - optparse-applicative 47 | - path 48 | - path-io 49 | - persistent 50 | - persistent-sqlite 51 | - random 52 | - resource-pool 53 | - safe 54 | - servant 55 | - servant-auth-client 56 | - servant-auth-server 57 | - servant-client 58 | - servant-server 59 | - text 60 | - time 61 | - unix 62 | - unliftio-core 63 | - unordered-containers 64 | - validity 65 | - validity-path 66 | - validity-text 67 | - wai 68 | - warp 69 | - yaml 70 | - yamlparse-applicative 71 | 72 | executables: 73 | hastory-server: 74 | main: Main.hs 75 | source-dirs: app/ 76 | ghc-options: 77 | - -rtsopts 78 | - -threaded 79 | - -with-rtsopts=-N 80 | dependencies: 81 | - monad-logger 82 | - hastory-server 83 | 84 | tests: 85 | hastory-server-test: 86 | main: Spec.hs 87 | source-dirs: test 88 | ghc-options: 89 | - -threaded 90 | - -rtsopts 91 | - -with-rtsopts=-N 92 | - -Wall 93 | dependencies: 94 | - QuickCheck 95 | - bytestring 96 | - case-insensitive 97 | - envparse 98 | - genvalidity-hspec 99 | - hastory-api 100 | - hastory-data 101 | - hastory-data-gen 102 | - hastory-server 103 | - hspec 104 | - http-conduit 105 | - http-types 106 | - optparse-applicative 107 | - persistent 108 | - resource-pool 109 | - servant 110 | - servant-auth-client 111 | - servant-client 112 | - text 113 | - yaml 114 | -------------------------------------------------------------------------------- /nix/nixos-module-test.nix: -------------------------------------------------------------------------------- 1 | { pkgs ? import ./pkgs.nix }: 2 | let 3 | hastory-production = 4 | import (./nixos-module.nix) { envname = "production"; }; 5 | home-manager = 6 | import ( 7 | builtins.fetchTarball { 8 | url = "https://github.com/rycee/home-manager/archive/472ca211cac604efdf621337067a237be9df389e.tar.gz"; 9 | sha256 = "sha256:1gbfsnd7zsxwqryxd4r6jz9sgdz6ghlkapws1cdxshrbxlwhqad1"; 10 | } + "/nixos/default.nix" 11 | ); 12 | 13 | port = 8001; 14 | in 15 | pkgs.nixosTest ( 16 | { lib, pkgs, ... }: 17 | { 18 | name = "hastory-module-test"; 19 | machine = 20 | { 21 | imports = 22 | [ 23 | hastory-production 24 | home-manager 25 | ]; 26 | services.hastory.production = 27 | { 28 | enable = true; 29 | inherit port; 30 | }; 31 | users.users.testuser.isNormalUser = true; 32 | home-manager.users.testuser = 33 | { pkgs, ... }: 34 | { 35 | imports = 36 | [ 37 | ./home-manager-module.nix 38 | ]; 39 | xdg.enable = true; 40 | home.stateVersion = "20.09"; 41 | programs.hastory = 42 | { 43 | enable = true; 44 | sync = 45 | { 46 | enable = true; 47 | server-url = "localhost:${builtins.toString port}"; 48 | username = "testuser"; 49 | password = "testpass"; 50 | }; 51 | }; 52 | }; 53 | }; 54 | testScript = 55 | '' 56 | from shlex import quote 57 | 58 | machine.start() 59 | machine.wait_for_unit("multi-user.target") 60 | 61 | machine.wait_for_unit("hastory-production.service") 62 | machine.wait_for_open_port(${builtins.toString port}) 63 | machine.succeed("curl localhost:${builtins.toString port}") 64 | 65 | machine.wait_for_unit("home-manager-testuser.service") 66 | 67 | 68 | def su(user, cmd): 69 | return f"su - {user} -c {quote(cmd)}" 70 | 71 | 72 | machine.succeed(su("testuser", "cat ~/.config/hastory/config.yaml")) 73 | 74 | # Sync 75 | # machine.succeed(su("testuser", "hastory register")) 76 | # machine.succeed(su("testuser", "hastory login")) 77 | # machine.succeed(su("testuser", "hastory sync")) 78 | ''; 79 | } 80 | ) 81 | -------------------------------------------------------------------------------- /hastory-server/test/Hastory/OptParseSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Hastory.OptParseSpec 4 | ( spec, 5 | ) 6 | where 7 | 8 | import Data.Yaml as Yaml 9 | import qualified Env 10 | import Hastory.Server.OptParse 11 | import Options.Applicative 12 | import Test.Hspec 13 | 14 | spec :: Spec 15 | spec = do 16 | describe "Arguments" 17 | $ it "parses 'serve --port 80 --log hastory.log --key jwk.key' correctly" 18 | $ do 19 | let args = ["serve", "--port", "80", "--log", "hastory.log", "--key", "jwk.key"] 20 | case execParserPure prefs_ argParser args of 21 | CompletionInvoked _ -> expectationFailure "Completion invoked" 22 | Failure err -> expectationFailure $ unlines ["Failed to parse arguments: ", show err] 23 | Success a -> 24 | a 25 | `shouldBe` Arguments 26 | ( CommandServe 27 | ( ServeArgs 28 | { serveArgsPort = Just 80, 29 | serveArgsLogFile = Just "hastory.log", 30 | serveArgsKeyFile = Just "jwk.key" 31 | } 32 | ) 33 | ) 34 | (Flags {flagsConfigFile = Nothing}) 35 | describe "Environment" 36 | $ it "parses HASTORY_SERVER_PORT, HASTORY_SERVER_LOG, and HASTORY_SERVER_KEY correctly" 37 | $ do 38 | let env = [("HASTORY_SERVER_PORT", "80"), ("HASTORY_SERVER_LOG", "hastory.log"), ("HASTORY_SERVER_KEY", "jwk.key")] 39 | case Env.parsePure environmentParser env of 40 | Left err -> expectationFailure $ unlines ["Failed to parse environment variables: ", show err] 41 | Right e -> 42 | e 43 | `shouldBe` ( Environment 44 | { envPort = Just 80, 45 | envLogFile = Just "hastory.log", 46 | envKeyFile = Just "jwk.key", 47 | envConfigFile = Nothing 48 | } 49 | ) 50 | describe "Configuration" 51 | $ it "parses 'port', 'log', and 'key' correctly" 52 | $ do 53 | let config = object [("port", Number 80), ("log", "hastory.log"), ("key", "jwk.key")] 54 | case parseEither parseJSON config of 55 | Left err -> expectationFailure $ unlines ["Failed to parse configuration: ", show err] 56 | Right c -> 57 | c 58 | `shouldBe` ( Configuration 59 | { configPort = Just 80, 60 | configLogFile = Just "hastory.log", 61 | configKeyFile = Just "jwk.key" 62 | } 63 | ) 64 | -------------------------------------------------------------------------------- /nix/nixos-module.nix: -------------------------------------------------------------------------------- 1 | { envname }: 2 | { lib, pkgs, config, ... }: 3 | with lib; 4 | 5 | let 6 | cfg = config.services.hastory."${envname}"; 7 | concatAttrs = attrList: fold (x: y: x // y) {} attrList; 8 | in 9 | { 10 | options.services.hastory."${envname}" = 11 | { 12 | enable = mkEnableOption "Hastory Services"; 13 | hosts = 14 | mkOption { 15 | type = types.listOf (types.string); 16 | example = [ "hastory.example.com" ]; 17 | default = []; 18 | description = "The host to serve web requests on"; 19 | }; 20 | port = 21 | mkOption { 22 | type = types.int; 23 | default = 8800; 24 | example = 8800; 25 | description = "The port to serve requests on"; 26 | }; 27 | }; 28 | config = 29 | let 30 | workingDir = "/www/hastory/${envname}/data/"; 31 | databaseFile = workingDir + "hastory.sqlite3"; 32 | backupDir = workingDir + "backups/"; 33 | webserver-service = 34 | let 35 | hastory-pkgs = (import (./pkgs.nix)).hastoryPackages; 36 | unlessNull = o: optionalAttrs (!builtins.isNull o); 37 | in 38 | { 39 | description = "Hastory ${envname} Service"; 40 | wantedBy = [ "multi-user.target" ]; 41 | environment = 42 | concatAttrs [ 43 | { HASTORY_SERVER_PORT = builtins.toString cfg.port; } 44 | ]; 45 | script = 46 | '' 47 | mkdir -p "${workingDir}" 48 | cd "${workingDir}" 49 | 50 | ${hastory-pkgs.hastory-server}/bin/hastory-server serve 51 | ''; 52 | serviceConfig = 53 | { 54 | Restart = "always"; 55 | RestartSec = 1; 56 | Nice = 15; 57 | }; 58 | unitConfig = 59 | { 60 | StartLimitIntervalSec = 0; 61 | # ensure Restart=always is always honoured 62 | }; 63 | }; 64 | in 65 | mkIf cfg.enable { 66 | systemd.services = 67 | { 68 | "hastory-${envname}" = webserver-service; 69 | }; 70 | networking.firewall.allowedTCPPorts = [ cfg.port ]; 71 | services.nginx.virtualHosts = 72 | { 73 | "${head (cfg.hosts)}" = 74 | { 75 | enableACME = true; 76 | forceSSL = true; 77 | locations."/".proxyPass = 78 | "http://localhost:${builtins.toString (cfg.port)}"; 79 | serverAliases = tail cfg.hosts; 80 | }; 81 | }; 82 | }; 83 | } 84 | -------------------------------------------------------------------------------- /hastory-data-gen/hastory-data-gen.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 1.12 2 | 3 | -- This file has been generated from package.yaml by hpack version 0.33.0. 4 | -- 5 | -- see: https://github.com/sol/hpack 6 | -- 7 | -- hash: dcb9ea12c9406baefe9bf1b9852cdf61264af479856f1e595d6920fb25469e79 8 | 9 | name: hastory-data-gen 10 | version: 0.0.0.0 11 | category: Command Line 12 | homepage: https://github.com/NorfairKing/hastory 13 | author: Tom Sydney Kerckhove 14 | maintainer: syd.kerckhove@gmail.com 15 | copyright: Copyright: (c) 2017-2018 Tom Sydney Kerckhove 16 | license: AllRightsReserved 17 | license-file: LICENSE 18 | build-type: Simple 19 | 20 | library 21 | exposed-modules: 22 | Hastory.Gen 23 | other-modules: 24 | Paths_hastory_data_gen 25 | hs-source-dirs: 26 | src/ 27 | ghc-options: -Wall 28 | build-depends: 29 | QuickCheck 30 | , base >=4.9 && <=5 31 | , genvalidity 32 | , genvalidity-hspec 33 | , genvalidity-hspec-aeson 34 | , genvalidity-path 35 | , genvalidity-text 36 | , genvalidity-time 37 | , hastory-data 38 | , hspec 39 | , path 40 | , path-io 41 | , persistent 42 | , text 43 | , validity 44 | , validity-path 45 | , validity-text 46 | default-language: Haskell2010 47 | 48 | test-suite hastory-data-test 49 | type: exitcode-stdio-1.0 50 | main-is: Spec.hs 51 | other-modules: 52 | Hastory.InstanceSpec 53 | TestImport 54 | Paths_hastory_data_gen 55 | hs-source-dirs: 56 | test/ 57 | default-extensions: NoImplicitPrelude 58 | ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall 59 | build-depends: 60 | QuickCheck 61 | , base >=4.9 && <=5 62 | , genvalidity 63 | , genvalidity-hspec 64 | , genvalidity-hspec-aeson 65 | , genvalidity-path 66 | , genvalidity-text 67 | , genvalidity-time 68 | , hastory-data 69 | , hastory-data-gen 70 | , hspec 71 | , path 72 | , path-io 73 | , safe 74 | , text 75 | , validity 76 | , validity-path 77 | , validity-text 78 | default-language: Haskell2010 79 | 80 | benchmark hastory-data-bench 81 | type: exitcode-stdio-1.0 82 | main-is: Main.hs 83 | other-modules: 84 | Import 85 | Paths_hastory_data_gen 86 | hs-source-dirs: 87 | bench 88 | ghc-options: -threaded -rtsopts -with-rtsopts=-T -Wall 89 | build-depends: 90 | QuickCheck 91 | , base 92 | , criterion 93 | , exceptions 94 | , genvalidity 95 | , hastory-api 96 | , hastory-data 97 | , hastory-data-gen 98 | , mtl 99 | , path 100 | , path-io 101 | default-language: Haskell2010 102 | -------------------------------------------------------------------------------- /hastory-server/src/Hastory/Server/TestUtils.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE RecordWildCards #-} 4 | 5 | module Hastory.Server.TestUtils 6 | ( ServerInfo (..), 7 | serverSpec, 8 | withNewUser, 9 | withTestServer, 10 | extractJWTCookie, 11 | module Network.HTTP.Types, 12 | module SQL, 13 | ) 14 | where 15 | 16 | import Control.Monad 17 | import Control.Monad.IO.Class 18 | import Control.Monad.Logger (runNoLoggingT) 19 | import Data.Pool (Pool) 20 | import qualified Data.Text as T 21 | import Database.Persist.Sql as SQL 22 | import Database.Persist.Sqlite 23 | import Hastory.API 24 | import Hastory.Data 25 | import Hastory.Data.Server.DB 26 | import Hastory.Server 27 | import Hastory.Server.HastoryHandler 28 | import Lens.Micro 29 | import Network.HTTP.Client (defaultManagerSettings, newManager) 30 | import Network.HTTP.Types 31 | import Network.Wai.Handler.Warp (testWithApplication) 32 | import Path.IO (resolveFile, withSystemTempDir) 33 | import Servant.Auth.Client 34 | import Servant.Auth.Server (defaultCookieSettings, defaultJWTSettings, generateKey) 35 | import Servant.Client 36 | import Test.Hspec 37 | import Test.Hspec.QuickCheck (modifyMaxShrinks, modifyMaxSuccess) 38 | 39 | data ServerInfo 40 | = ServerInfo 41 | { siClientEnv :: ClientEnv, 42 | siPool :: Pool SqlBackend 43 | } 44 | 45 | serverSpec :: SpecWith ServerInfo -> Spec 46 | serverSpec = modifyMaxShrinks (const 0) . modifyMaxSuccess (`div` 20) . around withTestServer 47 | 48 | withTestServer :: (ServerInfo -> IO a) -> IO a 49 | withTestServer func = do 50 | manager <- newManager defaultManagerSettings 51 | withSystemTempDir "hastory-server-test" $ \tmpDir -> do 52 | dbFile <- resolveFile tmpDir "server.db" 53 | jwk <- generateKey 54 | pwDifficulty <- passwordDifficultyOrExit 4 55 | let jwtSettings = defaultJWTSettings jwk 56 | runNoLoggingT 57 | $ withSqlitePoolInfo 58 | (mkSqliteConnectionInfo (T.pack $ fromAbsFile dbFile) & fkEnabled .~ False) 59 | 1 60 | $ \siPool -> 61 | liftIO $ do 62 | void $ runSqlPool (runMigrationSilent migrateAll) siPool 63 | let mkApp = pure $ app settings 64 | settings = ServerSettings siPool jwtSettings defaultCookieSettings pwDifficulty 65 | testWithApplication mkApp $ \p -> 66 | let siClientEnv = mkClientEnv manager (BaseUrl Http "127.0.0.1" p "") 67 | in func (ServerInfo {..}) 68 | 69 | type RegistrationData = (UserId, Token) 70 | 71 | withNewUser :: ClientEnv -> UserForm -> (RegistrationData -> Expectation) -> Expectation 72 | withNewUser clientEnv userForm func = do 73 | Right userId <- runClientM (createUserClient userForm) clientEnv 74 | Right resp <- runClientM (createSessionClient userForm) clientEnv 75 | case extractJWTCookie resp of 76 | Left err -> expectationFailure (show err) 77 | Right cookie -> func (userId, cookie) 78 | -------------------------------------------------------------------------------- /hastory-cli/package.yaml: -------------------------------------------------------------------------------- 1 | ghc-options: ["-optP-Wno-nonportable-include-path"] 2 | name: hastory-cli 3 | version: '0.0.0.0' 4 | category: Command Line 5 | author: Tom Sydney Kerckhove 6 | maintainer: syd.kerckhove@gmail.com 7 | copyright: ! 'Copyright: (c) 2016-2018 Tom Sydney Kerckhove' 8 | license: AllRightsReserved 9 | homepage: https://github.com/NorfairKing/hastory 10 | dependencies: 11 | - base >=4.9 && <=5 12 | - hastory-data 13 | - hastory-api 14 | 15 | library: 16 | source-dirs: src/ 17 | ghc-options: 18 | - -Wall 19 | - -Wincomplete-uni-patterns 20 | - -Wincomplete-record-updates 21 | - -Wredundant-constraints 22 | dependencies: 23 | - aeson 24 | - aeson-pretty 25 | - bytestring 26 | - deepseq 27 | - envparse 28 | - extra 29 | - hashable 30 | - hashable-time 31 | - hastory-data 32 | - hostname 33 | - http-client 34 | - http-conduit 35 | - monad-logger 36 | - mtl 37 | - optparse-applicative 38 | - path 39 | - path-io 40 | - persistent-sqlite 41 | - resourcet 42 | - safe 43 | - servant-client 44 | - servant-client-core 45 | - text 46 | - time 47 | - unix 48 | - unliftio-core 49 | - unordered-containers 50 | - validity 51 | - validity-path 52 | - validity-text 53 | - validity-time 54 | - yamlparse-applicative 55 | 56 | executables: 57 | hastory: 58 | main: Main.hs 59 | source-dirs: app/ 60 | ghc-options: 61 | - -threaded 62 | - -rtsopts 63 | - -with-rtsopts=-N 64 | dependencies: 65 | - hastory-cli 66 | 67 | tests: 68 | hastory-cli-test: 69 | main: Spec.hs 70 | source-dirs: test/ 71 | ghc-options: 72 | - -threaded 73 | - -rtsopts 74 | - -with-rtsopts=-N 75 | - -Wall 76 | dependencies: 77 | - base >=4.9 && <=5 78 | - QuickCheck 79 | - aeson 80 | - bytestring 81 | - envparse 82 | - genvalidity 83 | - genvalidity-hspec 84 | - genvalidity-hspec-aeson 85 | - genvalidity-path 86 | - genvalidity-text 87 | - genvalidity-time 88 | - hastory-cli 89 | - hastory-data 90 | - hastory-data-gen 91 | - hastory-server 92 | - hspec 93 | - mtl 94 | - optparse-applicative 95 | - path 96 | - path-io 97 | - safe 98 | - servant-client 99 | - servant-client-core 100 | - text 101 | - validity 102 | - validity-path 103 | - validity-text 104 | - yaml 105 | 106 | benchmarks: 107 | hastory-cli-bench: 108 | main: Main.hs 109 | source-dirs: bench 110 | ghc-options: 111 | - -threaded 112 | - -rtsopts 113 | - -with-rtsopts=-T 114 | - -Wall 115 | dependencies: 116 | - base 117 | - QuickCheck 118 | - criterion 119 | - exceptions 120 | - genvalidity 121 | - hastory-cli 122 | - hastory-data 123 | - hastory-data-gen 124 | - mtl 125 | - path 126 | - path-io 127 | - silently 128 | - unliftio 129 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Hastory 2 | 3 | Hastory keeps track of your terminal history and uses it to optimize the way you use your terminal. 4 | For example, it allows you to quickly jump to one of the directories you use the most. 5 | 6 | ## Installing the `hastory` binary from source 7 | 8 | First get the hastory sources: 9 | 10 | ``` shell 11 | git clone https://github.com/NorfairKing/hastory 12 | ``` 13 | 14 | You can install hastory with [`stack`](https://haskellstack.org/) 15 | 16 | ``` shell 17 | cd hastory 18 | stack install 19 | ``` 20 | 21 | ## Installing the Hastory harness 22 | 23 | To start recording your history with `hastory`, we need to hook into your shell's functionality to record every command you execute. 24 | 25 | With `hastory generate-gather-wrapper-script`, we can generate this script automatically. 26 | This means that the only thing you need to do is to add a one-liner to the script that is loaded on your shell's startup script. 27 | For bash, it suffices to add the following to .bashrc. 28 | 29 | ``` shell 30 | PROMPT_COMMAND="hastory_gather_" 31 | ``` 32 | 33 | On the other hand, hastory works for zsh if you add this line to .zshrc. 34 | 35 | ``` shell 36 | precmd() { 37 | hastory_gather_ 38 | } 39 | ``` 40 | 41 | When you restart your shell (for example by restarting your terminal), you should see history accumulating in `~/.hastory/command-history/hastory.db`. 42 | 43 | Note: Feel free to make sure that `hastory generate-gather-wrapper-script` is code that you actually want to run. 44 | 45 | ## Frequency-based directory changes 46 | 47 | > The ease of performing a task should be proportional to its frequency. 48 | 49 | Using your command history, `hastory` tries to predict the N directories that you are most likely to want to jump to. 50 | 51 | To use this feature, you need to hook into your shell again. 52 | With `hastory generate-change-directory-wrapper-script`, we can generate this script automatically. 53 | 54 | To source this script every time, put the following in your shell's startup script. (`.bashrc` for bash, `.zshrc` for zsh, for example.) 55 | 56 | ``` shell 57 | source <(hastory generate-change-directory-wrapper-script) 58 | ``` 59 | 60 | Now you can run `hastory_change_directory_` to list the directories that you might want to jump to. 61 | The output should look something like this: 62 | 63 | ``` shell 64 | /home/user $ hastory_change_directory_ 65 | 0 /home/user/work/ 66 | 1 /home/user/a/very/deep/directory/tree/that/i/use/often 67 | 2 /home/user/archive 68 | 3 /home/user/backup 69 | ``` 70 | 71 | If the directory that you want to jump to is in the list with index `i`, you can jump to it with `hastory_change_directory_ i`. 72 | 73 | ``` shell 74 | /home/user $ `hastory_change_directory_ 1 75 | /home/user/a/very/deep/directory/tree/that/i/use/often $ 76 | ``` 77 | 78 | Now you probably want to alias that long command `hastory_change_directory_` to something shorter like `f`, as follows: 79 | 80 | ``` shell 81 | alias f=hastory_change_directory_ 82 | ``` 83 | 84 | Note: Feel free to make sure that `hastory generate-change-directory-wrapper-script` is code that you actually want to run. 85 | 86 | ## What hastory stores 87 | 88 | In order to perform the above described features, hastory must keep a log of some things. 89 | The logs are all stored in ``~/.hastory``. 90 | The raw logs are stored in ``~/.hastory/command-history/hastory.db``. 91 | These files contain records of the commands you executed, when and in which directory they were executed as well as some extra information. 92 | The most list of most useful directories is cached in ``~/.hastory/recent-dirs-cache.json``. 93 | -------------------------------------------------------------------------------- /hastory-cli/src/Hastory/Cli/Commands/Recent.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE RecordWildCards #-} 5 | {-# LANGUAGE TemplateHaskell #-} 6 | 7 | module Hastory.Cli.Commands.Recent 8 | ( getRecentDirOpts, 9 | ) 10 | where 11 | 12 | import Control.Monad.IO.Unlift (MonadUnliftIO) 13 | import Control.Monad.Reader 14 | import Data.Aeson as JSON 15 | import Data.Aeson.Encode.Pretty as JSON 16 | import qualified Data.ByteString.Lazy as LB 17 | import qualified Data.HashMap.Lazy as HM 18 | import Data.List (sortOn) 19 | import Data.Ord 20 | import Data.Time.Clock (NominalDiffTime) 21 | import qualified Data.Time.Clock as Time 22 | import Data.Time.LocalTime (ZonedTime) 23 | import qualified Data.Time.LocalTime as Time 24 | import GHC.Generics (Generic) 25 | import Hastory.Cli.Internal 26 | import Hastory.Cli.OptParse.Types 27 | import Hastory.Cli.Utils (doCountsWith) 28 | import Hastory.Data.Client.DB 29 | import Path 30 | import Path.IO (forgivingAbsence, getHomeDir) 31 | 32 | getRecentDirOpts :: (MonadReader Settings m, MonadUnliftIO m) => Bool -> m [FilePath] 33 | getRecentDirOpts bypassCache = 34 | if bypassCache 35 | then recompute 36 | else do 37 | cacheFile <- recentDirsCacheFile 38 | mcontents <- liftIO $ forgivingAbsence $ LB.readFile $ toFilePath cacheFile 39 | case mcontents of 40 | Nothing -> recompute 41 | Just contents -> 42 | case JSON.eitherDecode contents of 43 | Left _ -> recompute -- If the file is corrupt, just don't care. 44 | Right RecentDirOptsCache {..} -> do 45 | now <- liftIO Time.getZonedTime 46 | if Time.diffUTCTime (Time.zonedTimeToUTC now) (Time.zonedTimeToUTC cacheTimestamp) 47 | > cacheInvalidationDuration 48 | then recompute 49 | else do 50 | cacheRecentDirOpts cacheRecentDirs 51 | pure cacheRecentDirs 52 | where 53 | recompute = do 54 | recentDirs <- computeRecentDirOpts 55 | unless bypassCache $ cacheRecentDirOpts recentDirs 56 | pure recentDirs 57 | 58 | cacheInvalidationDuration :: NominalDiffTime 59 | cacheInvalidationDuration = 10 -- seconds 60 | 61 | computeRecentDirOpts :: (MonadReader Settings m, MonadUnliftIO m) => m [FilePath] 62 | computeRecentDirOpts = do 63 | rawEnts <- getLastNDaysOfHistory 7 64 | home <- liftIO getHomeDir 65 | let entries = filter ((/= home) . entryWorkingDir) rawEnts 66 | now <- liftIO Time.getCurrentTime 67 | let dateFunc entry = 1 / d 68 | where 69 | d = realToFrac $ Time.diffUTCTime now (entryDateTime entry) 70 | let counts = doCountsWith (toFilePath . entryWorkingDir) dateFunc entries 71 | let tups = sortOn (Down . snd) $ HM.toList counts 72 | pure $ take 10 $ map fst tups 73 | 74 | cacheRecentDirOpts :: (MonadIO m, MonadReader Settings m) => [FilePath] -> m () 75 | cacheRecentDirOpts fs = do 76 | now <- liftIO Time.getZonedTime 77 | let cache = RecentDirOptsCache {cacheTimestamp = now, cacheRecentDirs = fs} 78 | cacheFile <- recentDirsCacheFile 79 | liftIO $ LB.writeFile (toFilePath cacheFile) $ JSON.encodePretty cache 80 | 81 | recentDirsCacheFile :: MonadReader Settings m => m (Path Abs File) 82 | recentDirsCacheFile = fmap ( $(mkRelFile "recent-dirs-cache.json")) hastoryDir 83 | 84 | data RecentDirOptsCache 85 | = RecentDirOptsCache 86 | { cacheTimestamp :: ZonedTime, 87 | cacheRecentDirs :: [FilePath] 88 | } 89 | deriving (Show, Generic) 90 | 91 | instance ToJSON RecentDirOptsCache 92 | 93 | instance FromJSON RecentDirOptsCache 94 | -------------------------------------------------------------------------------- /hastory-cli/src/Hastory/Cli/Commands/Sync.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE RecordWildCards #-} 4 | 5 | module Hastory.Cli.Commands.Sync 6 | ( sync, 7 | toEntry, 8 | ) 9 | where 10 | 11 | import Control.Monad.IO.Unlift (MonadUnliftIO) 12 | import Control.Monad.Reader 13 | import Data.Int 14 | import Data.Maybe 15 | import Database.Persist.Sqlite 16 | import Hastory.API 17 | import Hastory.Cli.Internal 18 | import Hastory.Cli.OptParse.Types 19 | import Hastory.Data 20 | import Hastory.Data.Client.DB hiding (migrateAll) 21 | import Hastory.Data.Server.DB hiding (migrateAll) 22 | import Network.HostName (getHostName) 23 | import System.Exit 24 | 25 | -- | Send local entries to sync server and fetch new entries from sync server. 26 | sync :: (MonadReader Settings m, MonadUnliftIO m) => SyncSettings -> m () 27 | sync (SyncSettings remoteInfo) = do 28 | HastoryClient {..} <- getHastoryClient remoteInfo 29 | syncRequest <- getSyncRequest 30 | let request = createEntryClient hastoryClientToken syncRequest 31 | response <- liftIO $ runHastoryClient request hastoryClientEnv 32 | case response of 33 | Left err -> liftIO $ die ("sync error: " ++ show err) 34 | Right serverEntries -> mapM_ updateOrInsert serverEntries 35 | 36 | getSyncRequest :: (MonadReader Settings m, MonadUnliftIO m) => m SyncRequest 37 | getSyncRequest = do 38 | maxSyncWitness <- fmap toSqlKey getMaxSyncWitness 39 | unSyncdLocalEntries <- map entityVal <$> readUnsyncdEntries 40 | hostname <- liftIO getHostName 41 | pure $ toSyncRequest unSyncdLocalEntries hostname maxSyncWitness 42 | 43 | updateOrInsert :: (MonadReader Settings m, MonadUnliftIO m) => Entity ServerEntry -> m EntryId 44 | updateOrInsert serverEntity = do 45 | let entry@Entry {..} = toEntry serverEntity 46 | entity <- 47 | runDb $ 48 | upsertBy 49 | (EntryData entryText entryWorkingDir entryDateTime entryUser) 50 | entry 51 | [EntrySyncWitness =. entrySyncWitness] 52 | pure $ entityKey entity 53 | 54 | -- | Mechanically, the syncWitness is the id (Int64) of the entry on the remote 55 | -- server. We assume that the client knows about all entries up to and including 56 | -- the maximum syncWitness in the local database. By sending the maximum 57 | -- syncWitness to the remote server when fetching entries, the server will only 58 | -- return entries that are unknown to the client. 59 | getMaxSyncWitness :: (MonadReader Settings m, MonadUnliftIO m) => m Int64 60 | getMaxSyncWitness = do 61 | mEntityEntry <- runDb $ selectFirst [EntrySyncWitness !=. Nothing] [Desc EntrySyncWitness] 62 | let mSyncWitness = entrySyncWitness . entityVal =<< mEntityEntry 63 | pure $ fromMaybe 0 mSyncWitness 64 | 65 | toEntry :: Entity ServerEntry -> Entry 66 | toEntry (Entity serverEntryId ServerEntry {..}) = Entry {..} 67 | where 68 | entryText = serverEntryText 69 | entryUser = serverEntryHostUser 70 | entryWorkingDir = serverEntryWorkingDir 71 | entryDateTime = serverEntryDateTime 72 | entrySyncWitness = Just (fromSqlKey serverEntryId) 73 | entryHostName = Just serverEntryHostName 74 | 75 | getHastoryClient :: (MonadUnliftIO m) => RemoteStorage -> m HastoryClient 76 | getHastoryClient (RemoteStorage baseUrl username password) = do 77 | eHastoryClient <- liftIO $ mkHastoryClient baseUrl username password 78 | case eHastoryClient of 79 | Left _err -> liftIO $ die "Unable to log in to server" 80 | Right client -> pure client 81 | 82 | readUnsyncdEntries :: (MonadReader Settings m, MonadUnliftIO m) => m [Entity Entry] 83 | readUnsyncdEntries = runDb $ selectList [EntrySyncWitness ==. Nothing] [] 84 | -------------------------------------------------------------------------------- /hastory-api/src/Hastory/API.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE GADTs #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | {-# LANGUAGE TypeOperators #-} 6 | {-# OPTIONS_GHC -Wno-orphans #-} 7 | 8 | module Hastory.API where 9 | 10 | import Control.Monad.Except 11 | import Data.Text (Text) 12 | import Data.Text.Encoding 13 | import Database.Persist 14 | import Hastory.Data 15 | import Hastory.Data.Server.DB (ServerEntry, UserId) 16 | import Network.HTTP.Client hiding (Proxy) 17 | import Network.HTTP.Conduit (tlsManagerSettings) 18 | import Servant 19 | import Servant.Auth.Client 20 | import Servant.Auth.Server hiding (BasicAuth) 21 | import Servant.Client hiding (manager) 22 | import Web.Cookie 23 | 24 | type RequiredQueryParam = QueryParam' '[Required, Strict] 25 | 26 | type AuthCookies = '[Header "Set-Cookie" Text] 27 | 28 | type EntriesPost = 29 | "entries" :> ReqBody '[JSON] SyncRequest :> PostCreated '[JSON] [Entity ServerEntry] 30 | 31 | type Protected = Auth '[JWT] AuthCookie 32 | 33 | type UsersAPI = "users" :> ReqBody '[JSON] UserForm :> PostCreated '[JSON] UserId 34 | 35 | type Sessions = 36 | "sessions" :> ReqBody '[JSON] UserForm :> Verb 'POST 204 '[JSON] (Headers AuthCookies NoContent) 37 | 38 | -- | Main Hastory API specification. 39 | type HastoryAPI = UsersAPI :<|> Sessions :<|> (Protected :> EntriesPost) 40 | 41 | -- | Proxy for Hastory API. 42 | api :: Proxy HastoryAPI 43 | api = Proxy 44 | 45 | data HastoryClient 46 | = HastoryClient 47 | { hastoryClientEnv :: ClientEnv, 48 | hastoryClientToken :: Token 49 | } 50 | 51 | -- | An ADT that encodes possible failures for mkHastoryClient 52 | data ClientEnvFailure 53 | = UnableToLogin 54 | | NoJWTTokenFound 55 | deriving (Show) 56 | 57 | -- | Creates a hastory client type. 58 | -- 59 | -- This type is needed for two reasons. First, because creating and destroying 60 | -- HTTP managers are expensive. Secondly, the user should only have to log in 61 | -- successfully once. 62 | -- 63 | -- Once a user gets a HastoryClient, it's being used throughout the entire life of the user. 64 | mkHastoryClient :: 65 | MonadIO m => BaseUrl -> Username -> Text -> m (Either ClientEnvFailure HastoryClient) 66 | mkHastoryClient url username password = do 67 | manager <- liftIO $ newManager tlsManagerSettings 68 | let clientEnv = mkClientEnv manager url 69 | userForm = UserForm username password 70 | res <- liftIO $ runClientM (createSessionClient userForm) clientEnv 71 | case res of 72 | Left _ -> pure $ Left UnableToLogin 73 | Right headers -> 74 | case extractJWTCookie headers of 75 | Left err -> pure $ Left err 76 | Right token -> pure $ Right (HastoryClient clientEnv token) 77 | 78 | -- | Extract token after successful login. 79 | extractJWTCookie :: Headers AuthCookies NoContent -> Either ClientEnvFailure Token 80 | extractJWTCookie headersList = 81 | case getHeadersHList headersList of 82 | HCons (Header a) _ -> pure . Token . setCookieValue . parseSetCookie . encodeUtf8 $ a 83 | _ -> Left NoJWTTokenFound 84 | 85 | -- | Hastory API client. 86 | -- 87 | -- See https://hackage.haskell.org/package/servant-client-0.16.0.1/docs/Servant-Client.html#v:client 88 | createUserClient :: UserForm -> ClientM UserId 89 | 90 | createSessionClient :: UserForm -> ClientM (Headers AuthCookies NoContent) 91 | 92 | createEntryClient :: Token -> SyncRequest -> ClientM [Entity ServerEntry] 93 | (createUserClient :<|> createSessionClient :<|> createEntryClient) = client api 94 | 95 | -- | Re-export of runClientM 96 | runHastoryClient :: ClientM a -> ClientEnv -> IO (Either ClientError a) 97 | runHastoryClient = runClientM 98 | -------------------------------------------------------------------------------- /hastory-cli/bench/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | module Main where 5 | 6 | import Control.Monad.Catch 7 | import Control.Monad.Reader 8 | import Control.Monad.State 9 | import Criterion.Main as Criterion 10 | import Criterion.Types as Criterion 11 | import Data.GenValidity 12 | import Hastory.Cli 13 | import Hastory.Cli.Commands.Gather 14 | import Hastory.Cli.OptParse 15 | import Hastory.Data.Client.DB 16 | import Hastory.Gen () 17 | import Import 18 | import System.Environment 19 | import System.Exit 20 | import System.IO.Silently 21 | import Test.QuickCheck 22 | import UnliftIO (MonadUnliftIO) 23 | 24 | main :: IO () 25 | main = 26 | let config = Criterion.defaultConfig {Criterion.reportFile = Just "bench.html"} 27 | in Criterion.defaultMainWith 28 | config 29 | [ bench "help" 30 | $ whnfIO 31 | $ runHastory ["--help"] 32 | `catch` ( \ec -> 33 | pure $ 34 | case ec of 35 | ExitSuccess -> () 36 | ExitFailure _ -> () 37 | ), 38 | bgroup "gather" $ map gatherBenchmark [10, 1000, 100000], 39 | bgroup "list-recent-directories" $ map listRecentDirsBenchmark [10, 1000, 100000] 40 | ] 41 | 42 | runHastory :: [String] -> IO () 43 | runHastory args = silence $ withArgs args hastoryCli 44 | 45 | gatherBenchmark :: Int -> Benchmark 46 | gatherBenchmark entryCount = 47 | envWithCleanup 48 | (createEnv entryCount) 49 | cleanupEnv 50 | (bench ("gather-" ++ show entryCount) . whnfIO . runReaderT (gatherFrom "ls -lr")) 51 | 52 | listRecentDirsBenchmark :: Int -> Benchmark 53 | listRecentDirsBenchmark entryCount = 54 | envWithCleanup 55 | (createEnv entryCount) 56 | cleanupEnv 57 | ( \_settings -> 58 | bench ("list-recent-directories-" ++ show entryCount) 59 | $ whnfIO 60 | $ runHastory ["list-recent-directories", "--bypass-cache", "--cache-dir", "/tmp/hastory-cache"] 61 | ) 62 | 63 | createEnv :: Int -> IO Settings 64 | createEnv entryCount = do 65 | settings <- prepareSettings 66 | _ <- runReaderT (prepareEntries entryCount) settings 67 | pure settings 68 | 69 | cleanupEnv :: Settings -> IO () 70 | cleanupEnv = removeDirRecur . setCacheDir 71 | 72 | prepareSettings :: IO Settings 73 | prepareSettings = do 74 | systemTempDir <- getTempDir 75 | hastoryTempDir <- createTempDir systemTempDir "hastory" 76 | pure $ Settings hastoryTempDir hastoryTempDir 77 | 78 | prepareEntries :: (MonadUnliftIO m, MonadReader Settings m) => Int -> m () 79 | prepareEntries i = do 80 | absDirs <- liftIO getSomeAbsDirs 81 | replicateM_ i $ do 82 | entry <- 83 | liftIO 84 | $ generate 85 | $ do 86 | t <- genValid 87 | d <- elements absDirs 88 | zt <- genValid 89 | u <- genValid 90 | pure 91 | Entry 92 | { entryText = t, 93 | entryWorkingDir = d, 94 | entryDateTime = zt, 95 | entryUser = u, 96 | entrySyncWitness = Nothing, 97 | entryHostName = Nothing 98 | } 99 | storeHistory entry 100 | 101 | getSomeAbsDirs :: MonadIO m => m [Path Abs Dir] 102 | getSomeAbsDirs = do 103 | home <- getHomeDir 104 | flip evalStateT 0 $ 105 | walkDirAccum 106 | ( Just 107 | ( \_ _ _ -> do 108 | nr <- get 109 | pure $ 110 | if (nr :: Int) >= 500 111 | then WalkFinish 112 | else WalkExclude [] 113 | ) 114 | ) 115 | ( \_ ds _ -> do 116 | modify (+ length ds) 117 | pure ds 118 | ) 119 | home 120 | -------------------------------------------------------------------------------- /nix/overlay.nix: -------------------------------------------------------------------------------- 1 | final: previous: 2 | with final.haskell.lib; 3 | 4 | { 5 | hastoryPackages = 6 | let 7 | hastoryPkg = 8 | name: 9 | doBenchmark ( 10 | addBuildDepend ( 11 | failOnAllWarnings ( 12 | disableLibraryProfiling ( 13 | final.haskellPackages.callCabal2nix name (final.gitignoreSource (../. + "/${name}")) {} 14 | ) 15 | ) 16 | ) (final.haskellPackages.autoexporter) 17 | ); 18 | in 19 | final.lib.genAttrs [ 20 | "hastory-api" 21 | "hastory-cli" 22 | "hastory-data" 23 | "hastory-data-gen" 24 | "hastory-server" 25 | ] hastoryPkg; 26 | haskellPackages = 27 | previous.haskellPackages.override ( 28 | old: 29 | { 30 | overrides = 31 | final.lib.composeExtensions ( 32 | old.overrides or ( 33 | _: 34 | _: 35 | {} 36 | ) 37 | ) ( 38 | self: super: 39 | let 40 | # Passwords 41 | passwordRepo = 42 | final.fetchFromGitHub { 43 | owner = "cdepillabout"; 44 | repo = "password"; 45 | rev = "26434d4f6888faf8dc36425b20b59f0b5056d7f5"; 46 | sha256 = 47 | "sha256:0kbrw7zcn687h61h574z5k8p7z671whblcrmd6q21gsa2pyrk4ll"; 48 | }; 49 | passwordPkg = 50 | name: 51 | dontCheck ( 52 | self.callCabal2nix name (passwordRepo + "/${name}") {} 53 | ); 54 | passwordPackages = 55 | final.lib.genAttrs [ 56 | "password" 57 | "password-instances" 58 | ] passwordPkg; 59 | 60 | # YamlParse-Applicative 61 | yamlparseApplicativeRepo = 62 | final.fetchFromGitHub { 63 | owner = "NorfairKing"; 64 | repo = "yamlparse-applicative"; 65 | rev = "1d381a4cbc9736a2defc916a93cfcf8000ee7e37"; 66 | sha256 = 67 | "sha256:18arsg3qzva8hz4f78a3n5zp639pway90xlvwac67fgv4sl6ivaz"; 68 | }; 69 | yamlparseApplicativePkg = 70 | name: 71 | dontCheck ( 72 | self.callCabal2nix name (yamlparseApplicativeRepo + "/${name}") {} 73 | ); 74 | yamlparseApplicativePackages = 75 | final.lib.genAttrs [ 76 | "yamlparse-applicative" 77 | ] yamlparseApplicativePkg; 78 | # envparse 79 | envparseRepo = 80 | final.fetchFromGitHub { 81 | owner = "supki"; 82 | repo = "envparse"; 83 | rev = "de5944fb09e9d941fafa35c0f05446af348e7b4d"; 84 | sha256 = 85 | "sha256:0piljyzplj3bjylnxqfl4zpc3vc88i9fjhsj06bk7xj48dv3jg3b"; 86 | }; 87 | envparsePkg = 88 | dontCheck ( 89 | self.callCabal2nix "envparse" (envparseRepo) {} 90 | ); 91 | in 92 | final.hastoryPackages // { 93 | # Passwords 94 | ghc-byteorder = self.callHackage "ghc-byteorder" "4.11.0.0.10" {}; 95 | envparse = envparsePkg; 96 | } // passwordPackages // yamlparseApplicativePackages 97 | ); 98 | } 99 | ); 100 | } 101 | -------------------------------------------------------------------------------- /hastory-server/hastory-server.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 1.12 2 | 3 | -- This file has been generated from package.yaml by hpack version 0.33.0. 4 | -- 5 | -- see: https://github.com/sol/hpack 6 | -- 7 | -- hash: 386668429c8437d0b6f3554bdc96b012badbef04420cf29b0df98cb713b5aea2 8 | 9 | name: hastory-server 10 | version: 0.0.0.0 11 | category: Command Line 12 | homepage: https://github.com/NorfairKing/hastory 13 | author: Tom Sydney Kerckhove 14 | maintainer: syd.kerckhove@gmail.com 15 | copyright: Copyright: (c) 2016-2018 Tom Sydney Kerckhove 16 | license: AllRightsReserved 17 | license-file: LICENSE 18 | build-type: Simple 19 | 20 | library 21 | exposed-modules: 22 | Hastory.Server 23 | Hastory.Server.Handler 24 | Hastory.Server.Handler.Entries 25 | Hastory.Server.Handler.Import 26 | Hastory.Server.Handler.Sessions 27 | Hastory.Server.Handler.Users 28 | Hastory.Server.HastoryHandler 29 | Hastory.Server.OptParse 30 | Hastory.Server.TestUtils 31 | Hastory.Server.Utils 32 | other-modules: 33 | Paths_hastory_server 34 | hs-source-dirs: 35 | src/ 36 | ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -fhide-source-paths 37 | build-depends: 38 | QuickCheck 39 | , aeson 40 | , base 41 | , bytestring 42 | , conduit 43 | , cookie 44 | , cryptonite 45 | , deepseq 46 | , envparse 47 | , exceptions 48 | , hashable 49 | , hashable-time 50 | , hastory-api 51 | , hastory-data 52 | , hostname 53 | , hspec 54 | , http-client 55 | , http-types 56 | , jose 57 | , microlens 58 | , monad-logger 59 | , mtl 60 | , optparse-applicative 61 | , path 62 | , path-io 63 | , persistent 64 | , persistent-sqlite 65 | , random 66 | , resource-pool 67 | , safe 68 | , servant 69 | , servant-auth-client 70 | , servant-auth-server 71 | , servant-client 72 | , servant-server 73 | , text 74 | , time 75 | , unix 76 | , unliftio-core 77 | , unordered-containers 78 | , validity 79 | , validity-path 80 | , validity-text 81 | , wai 82 | , warp 83 | , yaml 84 | , yamlparse-applicative 85 | default-language: Haskell2010 86 | 87 | executable hastory-server 88 | main-is: Main.hs 89 | other-modules: 90 | Paths_hastory_server 91 | hs-source-dirs: 92 | app/ 93 | ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -fhide-source-paths -rtsopts -threaded -with-rtsopts=-N 94 | build-depends: 95 | base >=4.9 && <=5 96 | , hastory-server 97 | , monad-logger 98 | default-language: Haskell2010 99 | 100 | test-suite hastory-server-test 101 | type: exitcode-stdio-1.0 102 | main-is: Spec.hs 103 | other-modules: 104 | Hastory.Handler.EntriesSpec 105 | Hastory.Handler.SessionsSpec 106 | Hastory.Handler.UsersSpec 107 | Hastory.OptParseSpec 108 | Paths_hastory_server 109 | hs-source-dirs: 110 | test 111 | ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -fhide-source-paths -threaded -rtsopts -with-rtsopts=-N -Wall 112 | build-depends: 113 | QuickCheck 114 | , base >=4.9 && <=5 115 | , bytestring 116 | , case-insensitive 117 | , envparse 118 | , genvalidity-hspec 119 | , hastory-api 120 | , hastory-data 121 | , hastory-data-gen 122 | , hastory-server 123 | , hspec 124 | , http-conduit 125 | , http-types 126 | , optparse-applicative 127 | , persistent 128 | , resource-pool 129 | , servant 130 | , servant-auth-client 131 | , servant-client 132 | , text 133 | , yaml 134 | default-language: Haskell2010 135 | -------------------------------------------------------------------------------- /hastory-server/src/Hastory/Server.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE RecordWildCards #-} 5 | {-# LANGUAGE ScopedTypeVariables #-} 6 | {-# LANGUAGE TypeOperators #-} 7 | 8 | module Hastory.Server where 9 | 10 | import Conduit (MonadUnliftIO) 11 | import Control.Monad 12 | import Control.Monad.Logger (MonadLogger, runStdoutLoggingT) 13 | import Control.Monad.Logger.CallStack (logInfo) 14 | import Crypto.JOSE.JWK 15 | import Data.Maybe 16 | import qualified Data.Text as T 17 | import qualified Database.Persist.Sqlite as SQL 18 | import Hastory.API 19 | import Hastory.Data.Server.DB (migrateAll) 20 | import Hastory.Server.Handler 21 | import Hastory.Server.OptParse 22 | import Lens.Micro hiding (sets) 23 | import qualified Network.HTTP.Types as HTTP 24 | import qualified Network.Wai as Wai 25 | import qualified Network.Wai.Handler.Warp as Warp 26 | import Path.IO 27 | import Servant.Auth.Server 28 | import Prelude 29 | 30 | -- | Main server logic for Hastory Server. 31 | server :: ServerSettings -> Server HastoryAPI 32 | server serverSettings = userHandler :<|> sessionHandler :<|> postEntryHandler 33 | where 34 | userHandler = flip runReaderT serverSettings . createUserHandler 35 | sessionHandler = flip runReaderT serverSettings . createSessionHandler 36 | postEntryHandler = 37 | withAuthenticated 38 | (\authCookie -> flip runReaderT serverSettings . createEntryHandler authCookie) 39 | (\_ -> runReaderT unAuthenticated serverSettings) 40 | 41 | -- | Main warp application. Consumes requests and produces responses. 42 | app :: ServerSettings -> Application 43 | app serverSettings@ServerSettings {..} = serveWithContext api context (server serverSettings) 44 | where 45 | context = serverSetCookieSettings :. serverSetJWTSettings :. EmptyContext 46 | 47 | -- | Logging action that will be executed with every request. 48 | mkWarpLogger :: FilePath -> Wai.Request -> HTTP.Status -> Maybe Integer -> IO () 49 | mkWarpLogger logPath req _ _ = appendFile logPath $ show req <> "\n" 50 | 51 | -- | Warp server settings. 52 | mkWarpSettings :: ServeSettings -> Warp.Settings 53 | mkWarpSettings ServeSettings {..} = 54 | Warp.setTimeout 20 55 | $ Warp.setPort serveSettingsPort 56 | $ Warp.setLogger (mkWarpLogger $ toFilePath serveSettingsLogFile) Warp.defaultSettings 57 | 58 | -- | Displays the port this server will use. This port is configurable via command-line flags. 59 | reportPort :: MonadLogger m => Int -> m () 60 | reportPort port = logInfo $ "Starting server on port " <> T.pack (show port) 61 | 62 | -- | Runs command by reading from the command line, environment, and config file. 63 | hastoryServer :: IO () 64 | hastoryServer = do 65 | Instructions d sets <- getInstructions 66 | runReaderT (dispatch d) sets 67 | 68 | dispatch :: MonadUnliftIO m => Dispatch -> m () 69 | dispatch (DispatchServe serveSets) = hastoryServe serveSets 70 | 71 | -- | Starts a webserver by reading command line flags 72 | hastoryServe :: MonadUnliftIO m => ServeSettings -> m () 73 | hastoryServe serveSettings@ServeSettings {..} = 74 | runStdoutLoggingT $ do 75 | signingKey <- liftIO (getSigningKey serveSettingsKeyFile) 76 | serverSetPwDifficulty <- liftIO (passwordDifficultyOrExit 10) 77 | let serverSetCookieSettings = defaultCookieSettings 78 | serverSetJWTSettings = defaultJWTSettings signingKey 79 | reportPort serveSettingsPort 80 | dbFile <- resolveFile' "hastory.sqlite3" 81 | ensureDir (parent dbFile) 82 | SQL.withSqlitePoolInfo 83 | (SQL.mkSqliteConnectionInfo (T.pack $ fromAbsFile dbFile) & SQL.fkEnabled .~ False) 84 | 1 85 | $ \serverSetPool -> do 86 | void $ SQL.runSqlPool (SQL.runMigrationSilent migrateAll) serverSetPool 87 | liftIO $ Warp.runSettings (mkWarpSettings serveSettings) (app ServerSettings {..}) 88 | 89 | -- | Reads the signing key from the given file. If the file does not exist, then 90 | -- the file, with a JWK, will be created and read from. 91 | getSigningKey :: Path Abs File -> IO JWK 92 | getSigningKey keyPath = do 93 | ensureDir (parent keyPath) 94 | fileExists <- doesFileExist keyPath 95 | unless fileExists (writeKey path) 96 | readKey path 97 | where 98 | path = toFilePath keyPath 99 | 100 | withAuthenticated :: (b -> a) -> a -> AuthResult b -> a 101 | withAuthenticated whenAuthenticated whenNotAuthenticated authRes = 102 | case authRes of 103 | Authenticated res -> whenAuthenticated res 104 | _ -> whenNotAuthenticated 105 | -------------------------------------------------------------------------------- /nix/home-manager-module.nix: -------------------------------------------------------------------------------- 1 | { lib, pkgs, config, ... }: 2 | 3 | with lib; 4 | 5 | let 6 | cfg = config.programs.hastory; 7 | 8 | 9 | in 10 | { 11 | options = 12 | { 13 | programs.hastory = 14 | { 15 | enable = mkEnableOption "Hastory cli and syncing"; 16 | extraConfig = 17 | mkOption { 18 | type = types.str; 19 | description = "Extra contents for the config file"; 20 | default = ""; 21 | }; 22 | sync = 23 | mkOption { 24 | default = null; 25 | type = 26 | types.nullOr ( 27 | types.submodule { 28 | options = 29 | { 30 | enable = mkEnableOption "Hastory syncing"; 31 | server-url = 32 | mkOption { 33 | type = types.str; 34 | example = "api.hastory.cs-syd.eu"; 35 | description = "The url of the sync server"; 36 | }; 37 | username = 38 | mkOption { 39 | type = types.str; 40 | example = "syd"; 41 | description = 42 | "The username to use when logging into the sync server"; 43 | }; 44 | password = 45 | mkOption { 46 | type = types.str; 47 | example = "hunter12"; 48 | description = 49 | "The password to use when logging into the sync server"; 50 | }; 51 | }; 52 | } 53 | ); 54 | }; 55 | }; 56 | }; 57 | config = 58 | let 59 | hastoryPkgs = (import ./pkgs.nix).hastoryPackages; 60 | configContents = 61 | cfg: 62 | '' 63 | 64 | ${cfg.extraConfig} 65 | 66 | ''; 67 | syncConfigContents = 68 | syncCfg: 69 | optionalString (syncCfg.enable or false) '' 70 | 71 | url: "${cfg.sync.server-url}" 72 | username: "${cfg.sync.username}" 73 | password: "${cfg.sync.password}" 74 | 75 | ''; 76 | 77 | 78 | syncHastoryName = "sync-hastory"; 79 | syncHastoryService = 80 | { 81 | Unit = 82 | { 83 | Description = "Sync hastory"; 84 | Wants = [ "network-online.target" ]; 85 | }; 86 | Service = 87 | { 88 | ExecStart = 89 | "${pkgs.writeShellScript "sync-hastory-service-ExecStart" 90 | '' 91 | exec ${hastoryPkgs.hastory-cli}/bin/hastory sync 92 | ''}"; 93 | Type = "oneshot"; 94 | }; 95 | }; 96 | syncHastoryTimer = 97 | { 98 | Unit = 99 | { 100 | Description = "Sync hastory every day"; 101 | }; 102 | Install = 103 | { 104 | WantedBy = [ "timers.target" ]; 105 | }; 106 | Timer = 107 | { 108 | OnCalendar = "daily"; 109 | Persistent = true; 110 | Unit = "${syncHastoryName}.service"; 111 | }; 112 | }; 113 | 114 | hastoryConfigContents = 115 | concatStringsSep "\n" [ 116 | (configContents cfg) 117 | (syncConfigContents cfg.sync) 118 | ]; 119 | 120 | services = 121 | ( 122 | optionalAttrs (cfg.sync.enable or false) { 123 | "${syncHastoryName}" = syncHastoryService; 124 | } 125 | ); 126 | timers = 127 | ( 128 | optionalAttrs (cfg.sync.enable or false) { 129 | "${syncHastoryName}" = syncHastoryTimer; 130 | } 131 | ); 132 | packages = 133 | [ 134 | hastoryPkgs.hastory-cli 135 | ]; 136 | 137 | 138 | in 139 | mkIf cfg.enable { 140 | xdg = 141 | { 142 | configFile."hastory/config.yaml".text = hastoryConfigContents; 143 | }; 144 | systemd.user = 145 | { 146 | startServices = true; 147 | services = services; 148 | timers = timers; 149 | }; 150 | home.packages = packages; 151 | }; 152 | } 153 | -------------------------------------------------------------------------------- /hastory-cli/hastory-cli.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 1.12 2 | 3 | -- This file has been generated from package.yaml by hpack version 0.33.0. 4 | -- 5 | -- see: https://github.com/sol/hpack 6 | -- 7 | -- hash: 32b8e2ff1ae30e7095751ded07f16ff4358ded748bbb450b3d24e4d03ce792d4 8 | 9 | name: hastory-cli 10 | version: 0.0.0.0 11 | category: Command Line 12 | homepage: https://github.com/NorfairKing/hastory 13 | author: Tom Sydney Kerckhove 14 | maintainer: syd.kerckhove@gmail.com 15 | copyright: Copyright: (c) 2016-2018 Tom Sydney Kerckhove 16 | license: AllRightsReserved 17 | license-file: LICENSE 18 | build-type: Simple 19 | 20 | library 21 | exposed-modules: 22 | Hastory.Cli 23 | Hastory.Cli.Commands.ChangeDir 24 | Hastory.Cli.Commands.Gather 25 | Hastory.Cli.Commands.GenChangeWrapper 26 | Hastory.Cli.Commands.GenGatherWrapper 27 | Hastory.Cli.Commands.ListDir 28 | Hastory.Cli.Commands.Recent 29 | Hastory.Cli.Commands.Register 30 | Hastory.Cli.Commands.SuggestAlias 31 | Hastory.Cli.Commands.Sync 32 | Hastory.Cli.Internal 33 | Hastory.Cli.OptParse 34 | Hastory.Cli.OptParse.Types 35 | Hastory.Cli.Utils 36 | other-modules: 37 | Paths_hastory_cli 38 | hs-source-dirs: 39 | src/ 40 | ghc-options: -optP-Wno-nonportable-include-path -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wredundant-constraints 41 | build-depends: 42 | aeson 43 | , aeson-pretty 44 | , base >=4.9 && <=5 45 | , bytestring 46 | , deepseq 47 | , envparse 48 | , extra 49 | , hashable 50 | , hashable-time 51 | , hastory-api 52 | , hastory-data 53 | , hostname 54 | , http-client 55 | , http-conduit 56 | , monad-logger 57 | , mtl 58 | , optparse-applicative 59 | , path 60 | , path-io 61 | , persistent-sqlite 62 | , resourcet 63 | , safe 64 | , servant-client 65 | , servant-client-core 66 | , text 67 | , time 68 | , unix 69 | , unliftio-core 70 | , unordered-containers 71 | , validity 72 | , validity-path 73 | , validity-text 74 | , validity-time 75 | , yamlparse-applicative 76 | default-language: Haskell2010 77 | 78 | executable hastory 79 | main-is: Main.hs 80 | other-modules: 81 | Paths_hastory_cli 82 | hs-source-dirs: 83 | app/ 84 | ghc-options: -optP-Wno-nonportable-include-path -threaded -rtsopts -with-rtsopts=-N 85 | build-depends: 86 | base >=4.9 && <=5 87 | , hastory-api 88 | , hastory-cli 89 | , hastory-data 90 | default-language: Haskell2010 91 | 92 | test-suite hastory-cli-test 93 | type: exitcode-stdio-1.0 94 | main-is: Spec.hs 95 | other-modules: 96 | Hastory.Cli.Commands.GenGatherWrapperSpec 97 | Hastory.Cli.Commands.RegisterSpec 98 | Hastory.Cli.Commands.SuggestionSpec 99 | Hastory.Cli.Commands.SyncSpec 100 | Hastory.Cli.OptParse.TypesSpec 101 | Hastory.Cli.OptParseSpec 102 | TestImport 103 | Paths_hastory_cli 104 | hs-source-dirs: 105 | test/ 106 | ghc-options: -optP-Wno-nonportable-include-path -threaded -rtsopts -with-rtsopts=-N -Wall 107 | build-depends: 108 | QuickCheck 109 | , aeson 110 | , base >=4.9 && <=5 111 | , bytestring 112 | , envparse 113 | , genvalidity 114 | , genvalidity-hspec 115 | , genvalidity-hspec-aeson 116 | , genvalidity-path 117 | , genvalidity-text 118 | , genvalidity-time 119 | , hastory-api 120 | , hastory-cli 121 | , hastory-data 122 | , hastory-data-gen 123 | , hastory-server 124 | , hspec 125 | , mtl 126 | , optparse-applicative 127 | , path 128 | , path-io 129 | , safe 130 | , servant-client 131 | , servant-client-core 132 | , text 133 | , validity 134 | , validity-path 135 | , validity-text 136 | , yaml 137 | default-language: Haskell2010 138 | 139 | benchmark hastory-cli-bench 140 | type: exitcode-stdio-1.0 141 | main-is: Main.hs 142 | other-modules: 143 | Import 144 | Paths_hastory_cli 145 | hs-source-dirs: 146 | bench 147 | ghc-options: -optP-Wno-nonportable-include-path -threaded -rtsopts -with-rtsopts=-T -Wall 148 | build-depends: 149 | QuickCheck 150 | , base 151 | , criterion 152 | , exceptions 153 | , genvalidity 154 | , hastory-api 155 | , hastory-cli 156 | , hastory-data 157 | , hastory-data-gen 158 | , mtl 159 | , path 160 | , path-io 161 | , silently 162 | , unliftio 163 | default-language: Haskell2010 164 | -------------------------------------------------------------------------------- /hastory-cli/test/Hastory/Cli/Commands/SyncSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE RecordWildCards #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | 5 | module Hastory.Cli.Commands.SyncSpec 6 | ( spec, 7 | ) 8 | where 9 | 10 | import Control.Monad.Reader 11 | import Hastory.Cli.Commands.Sync 12 | import Hastory.Cli.Internal 13 | import Hastory.Data 14 | import Hastory.Data.Client.DB 15 | import Hastory.Data.Server.DB 16 | import Hastory.Gen () 17 | import Hastory.Server.TestUtils 18 | import Hastory.Server.Utils 19 | import Servant.Client 20 | import TestImport 21 | 22 | spec :: Spec 23 | spec = 24 | serverSpec 25 | $ describe "sync" 26 | $ do 27 | it "sends unsync'd data to the sync server" $ \ServerInfo {..} -> 28 | forAllValid $ \userForm -> 29 | forAllValid $ \entries -> do 30 | let remoteInfo = RemoteStorage (baseUrl siClientEnv) username password 31 | username = userFormUserName userForm 32 | password = userFormPassword userForm 33 | withNewUser siClientEnv userForm $ \_registrationData -> 34 | withSystemTempDir "local-hastory" $ \tmpDir -> do 35 | let settings = Settings tmpDir tmpDir 36 | localEntries = nub (map nullifySyncWitness entries) 37 | _ <- createUnsyncdEntries localEntries settings 38 | runReaderT (sync $ SyncSettings remoteInfo) settings 39 | serverEntries :: [Entity ServerEntry] <- runSqlPool (selectList [] []) siPool 40 | length serverEntries `shouldBe` length localEntries 41 | it "fetches new entries from the sync server" $ \ServerInfo {..} -> 42 | forAllValid $ \userForm -> 43 | forAllValid $ \(entryOne, entryTwo) -> do 44 | let remoteStorage = RemoteStorage (baseUrl siClientEnv) username password 45 | username = userFormUserName userForm 46 | password = userFormPassword userForm 47 | withNewUser siClientEnv userForm $ \(userId, _token) -> 48 | withSystemTempDir "local-hastory" $ \tmpDir -> do 49 | let entries = map nullifySyncWitness [entryOne, entryTwo] 50 | serverEntries = map (toServerEntry userId "localhost") entries 51 | _ <- runSqlPool (insertMany serverEntries) siPool 52 | let settings = Settings tmpDir tmpDir 53 | _ <- runReaderT (sync $ SyncSettings remoteStorage) settings 54 | localEntities <- runReaderT (runDb $ selectList [] [Desc EntrySyncWitness]) settings 55 | serverEntities <- runSqlPool (selectList [] [Desc ServerEntryId]) siPool 56 | length localEntities `shouldBe` 2 57 | length serverEntities `shouldBe` 2 58 | map entityVal localEntities `shouldBe` map toEntry serverEntities 59 | it "updates local entries when syncing" $ \ServerInfo {..} -> 60 | forAllValid $ \userForm -> 61 | forAllValid $ \entry -> do 62 | let remote = RemoteStorage (baseUrl siClientEnv) username password 63 | username = userFormUserName userForm 64 | password = userFormPassword userForm 65 | withNewUser siClientEnv userForm $ \(_userId, _token) -> 66 | withSystemTempDir "local-hastory" $ \tmpDir -> do 67 | let set = Settings tmpDir tmpDir 68 | entries = map nullifySyncWitness [entry] 69 | _ <- createUnsyncdEntries entries set 70 | _ <- runReaderT (sync $ SyncSettings remote) set 71 | localEntities :: [Entity Entry] <- runReaderT (runDb $ selectList [] []) set 72 | map (entrySyncWitness . entityVal) localEntities `shouldSatisfy` all isJust 73 | it "does not overwrite local entry host name" $ \ServerInfo {..} -> 74 | forAllValid $ \userForm -> 75 | forAllValid $ \entry -> do 76 | let remote = RemoteStorage (baseUrl siClientEnv) username password 77 | username = userFormUserName userForm 78 | password = userFormPassword userForm 79 | withNewUser siClientEnv userForm $ \(_userId, _token) -> 80 | withSystemTempDir "local-hastory" $ \tmpDir -> do 81 | let set = Settings tmpDir tmpDir 82 | entries = map (nullifyHostName . nullifySyncWitness) [entry] 83 | _ <- createUnsyncdEntries entries set 84 | _ <- runReaderT (sync $ SyncSettings remote) set 85 | localEntities :: [Entity Entry] <- runReaderT (runDb $ selectList [] []) set 86 | map (entryHostName . entityVal) localEntities `shouldSatisfy` all isNothing 87 | 88 | createUnsyncdEntries :: [Entry] -> Settings -> IO [Key Entry] 89 | createUnsyncdEntries entries = runReaderT (runDb $ insertMany entries) 90 | 91 | nullifySyncWitness :: Entry -> Entry 92 | nullifySyncWitness entry = entry {entrySyncWitness = Nothing} 93 | 94 | nullifyHostName :: Entry -> Entry 95 | nullifyHostName entry = entry {entryHostName = Nothing} 96 | -------------------------------------------------------------------------------- /hastory-server/test/Hastory/Handler/EntriesSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE RecordWildCards #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | 5 | module Hastory.Handler.EntriesSpec 6 | ( spec, 7 | ) 8 | where 9 | 10 | import Control.Monad 11 | import Hastory.API 12 | import Hastory.Data 13 | import Hastory.Data.Server.DB 14 | import Hastory.Gen () 15 | import Hastory.Server.TestUtils 16 | import Hastory.Server.Utils 17 | import Servant.Auth.Client 18 | import Servant.Client 19 | import Test.Hspec 20 | import Test.Validity 21 | 22 | spec :: Spec 23 | spec = serverSpec postEntries 24 | 25 | postEntries :: SpecWith ServerInfo 26 | postEntries = 27 | describe "POST /entries" $ do 28 | context "incorrect token" 29 | $ it "is a 401" 30 | $ \ServerInfo {..} -> 31 | forAllValid $ \syncReq -> do 32 | let incorrectToken = Token "badToken" 33 | Left (FailureResponse _requestF resp) <- 34 | runClientM (createEntryClient incorrectToken syncReq) siClientEnv 35 | responseStatusCode resp `shouldBe` status401 36 | context "correct token" $ do 37 | it "saves entry to database" $ \ServerInfo {..} -> 38 | forAllValid $ \syncReq -> 39 | forAllValid $ \userForm -> 40 | withNewUser siClientEnv userForm $ \(userId, token) -> do 41 | Right _ <- runClientM (createEntryClient token syncReq) siClientEnv 42 | entries <- runSqlPool (selectList [] []) siPool :: IO [Entity ServerEntry] 43 | map entityVal entries `shouldBe` toServerEntries syncReq userId 44 | context "when same entry is sync'd twice" $ do 45 | it "the db does not change between the first sync and the second sync" $ \ServerInfo {..} -> 46 | forAllValid $ \syncReq -> 47 | forAllValid $ \userForm -> 48 | withNewUser siClientEnv userForm $ \(_, token) -> do 49 | Right _ <- runClientM (createEntryClient token syncReq) siClientEnv 50 | entriesAfterFirstSync <- 51 | runSqlPool (selectList [] []) siPool :: IO [Entity ServerEntry] 52 | Right _ <- runClientM (createEntryClient token syncReq) siClientEnv 53 | entriesAfterSecondSync <- 54 | runSqlPool (selectList [] []) siPool :: IO [Entity ServerEntry] 55 | entriesAfterSecondSync `shouldBe` entriesAfterFirstSync 56 | it "db only persists one entry" $ \ServerInfo {..} -> 57 | forAllValid $ \entry -> 58 | forAllValid $ \userForm -> 59 | withNewUser siClientEnv userForm $ \(_, token) -> do 60 | let syncReq = SyncRequest [entry] "hostname" (toSqlKey 0) 61 | replicateM_ 2 $ runClientM (createEntryClient token syncReq) siClientEnv 62 | dbEntries <- runSqlPool (selectList [] []) siPool :: IO [Entity ServerEntry] 63 | length dbEntries `shouldBe` 1 64 | it "responds with server entries" $ \ServerInfo {..} -> 65 | forAllValid $ \userForm -> 66 | forAllValid $ \entry -> 67 | withNewUser siClientEnv userForm $ \(_userId, token) -> do 68 | let syncReq = SyncRequest [entry] "hostname" (toSqlKey 0) 69 | Right responseEntries <- runClientM (createEntryClient token syncReq) siClientEnv 70 | serverEntries <- runSqlPool (selectList [] []) siPool 71 | serverEntries `shouldBe` responseEntries 72 | it "responds with server entries that belong to the user" $ \ServerInfo {..} -> 73 | forAllValid $ \userFormOne -> 74 | forAllValid $ \userFormTwo -> 75 | forAllValid $ \entryOne -> 76 | forAllValid $ \entryTwo -> 77 | withNewUser siClientEnv userFormOne $ \(userIdOne, userOneToken) -> 78 | withNewUser siClientEnv userFormTwo $ \(userIdTwo, _userTwoToken) -> do 79 | let serverEntryOne = toServerEntry userIdOne "host" entryOne 80 | serverEntryTwo = toServerEntry userIdTwo "host" entryTwo 81 | userOneServerEntry <- runSqlPool (insertEntity serverEntryOne) siPool 82 | _userTwoServerEntry <- runSqlPool (insertEntity serverEntryTwo) siPool 83 | let syncReq = SyncRequest [entryOne] "host" (toSqlKey 0) 84 | Right responseEntries <- 85 | runClientM (createEntryClient userOneToken syncReq) siClientEnv 86 | responseEntries `shouldBe` [userOneServerEntry] 87 | it "responds with server entries that have an ID greater than the logPosition" $ \ServerInfo {..} -> 88 | forAllValid $ \(entryOne, entryTwo, entryThree) -> 89 | forAllValid $ \userForm -> 90 | withNewUser siClientEnv userForm $ \(userId, token) -> do 91 | let serverEntries = 92 | map (toServerEntry userId "host") [entryOne, entryTwo, entryThree] 93 | [_small, mid, large] <- runSqlPool (insertMany serverEntries) siPool 94 | let syncReq = SyncRequest [] "host" mid 95 | Right responseEntries <- runClientM (createEntryClient token syncReq) siClientEnv 96 | map entityKey responseEntries `shouldBe` [large] 97 | -------------------------------------------------------------------------------- /hastory-cli/src/Hastory/Cli/OptParse/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | module Hastory.Cli.OptParse.Types where 5 | 6 | import Control.DeepSeq 7 | import Data.Aeson 8 | import Data.Text (Text) 9 | import GHC.Generics 10 | import Hastory.Data 11 | import Servant.Client.Core.Reexport (BaseUrl, parseBaseUrl) 12 | import YamlParse.Applicative 13 | 14 | data Arguments 15 | = Arguments Command Flags 16 | deriving (Show) 17 | 18 | data Instructions 19 | = Instructions Dispatch Settings 20 | deriving (Show) 21 | 22 | data Command 23 | = CommandGather GatherFlags 24 | | CommandGenGatherWrapperScript GenGatherWrapperScriptFlags 25 | | CommandListRecentDirs ListRecentDirFlags 26 | | CommandChangeDir ChangeDirFlags 27 | | CommandGenChangeWrapperScript GenChangeWrapperScriptFlags 28 | | CommandSuggestAlias SuggestAliasFlags 29 | | CommandSync SyncFlags 30 | | CommandRegister RegisterFlags 31 | deriving (Show, Eq) 32 | 33 | data GatherFlags 34 | = GatherFlags 35 | deriving (Show, Eq) 36 | 37 | data GenGatherWrapperScriptFlags 38 | = GenGatherWrapperScriptFlags 39 | deriving (Show, Eq) 40 | 41 | newtype ListRecentDirFlags 42 | = ListRecentDirFlags 43 | { lrdArgBypassCache :: Maybe Bool 44 | } 45 | deriving (Show, Eq) 46 | 47 | newtype ChangeDirFlags 48 | = ChangeDirFlags 49 | { changeDirFlagsIdx :: Int 50 | } 51 | deriving (Show, Eq) 52 | 53 | data GenChangeWrapperScriptFlags 54 | = GenChangeWrapperScriptFlags 55 | deriving (Show, Eq) 56 | 57 | data SuggestAliasFlags 58 | = SuggestAliasFlags 59 | deriving (Show, Eq) 60 | 61 | type SyncFlags = RemoteStorageFlags 62 | 63 | type RegisterFlags = RemoteStorageFlags 64 | 65 | data RemoteStorageFlags = RemoteStorageFlags {remoteStorageFlagsServer :: Maybe BaseUrl, remoteStorageFlagsUsername :: Maybe Username, remoteStorageFlagsPassword :: Maybe Text} deriving (Show, Eq) 66 | 67 | data Flags 68 | = Flags 69 | { flagCacheDir :: Maybe FilePath, 70 | flagConfigFile :: Maybe FilePath, 71 | flagDataDir :: Maybe FilePath 72 | } 73 | deriving (Show, Eq) 74 | 75 | data Environment 76 | = Environment 77 | { envCacheDir :: Maybe FilePath, 78 | envConfigFile :: Maybe FilePath, 79 | envStorageServer :: Maybe BaseUrl, 80 | envStorageUsername :: Maybe Username, 81 | envStoragePassword :: Maybe Text, 82 | envLrdBypassCache :: Maybe Bool, 83 | envDataDir :: Maybe FilePath 84 | } 85 | deriving (Show, Eq) 86 | 87 | data Configuration 88 | = Configuration 89 | { configCacheDir :: Maybe FilePath, 90 | configStorageServer :: Maybe BaseUrl, 91 | configStorageUsername :: Maybe Username, 92 | configStoragePassword :: Maybe Text, 93 | configLrdBypassCache :: Maybe Bool, 94 | configDataDir :: Maybe FilePath 95 | } 96 | deriving (Show, Eq) 97 | 98 | instance YamlSchema Configuration where 99 | yamlSchema = parseObject 100 | where 101 | parseObject = 102 | objectParser "Configuration" $ 103 | Configuration <$> optionalField "cache-dir" "the cache directory for hastory" 104 | <*> optionalFieldWith 105 | "url" 106 | "URL of the central storage server" 107 | (maybeParser parseBaseUrl yamlSchema) 108 | <*> optionalFieldWith 109 | "username" 110 | "Username for the central storage server" 111 | (maybeParser parseUsername yamlSchema) 112 | <*> optionalField "password" "Password for the central storage server" 113 | <*> optionalField 114 | "bypass-cache" 115 | "Whether to recompute the recent directory options or use a cache when available" 116 | <*> optionalField "data-dir" "the data directory for hastory" 117 | 118 | instance FromJSON Configuration where 119 | parseJSON = viaYamlSchema 120 | 121 | data Dispatch 122 | = DispatchGather GatherSettings 123 | | DispatchGenGatherWrapperScript GenGatherWrapperScriptSettings 124 | | DispatchListRecentDirs ListRecentDirSettings 125 | | DispatchChangeDir ChangeDirSettings 126 | | DispatchGenChangeWrapperScript GenChangeWrapperScriptSettings 127 | | DispatchSuggestAlias SuggestAliasSettings 128 | | DispatchSync SyncSettings 129 | | DispatchRegister RegisterSettings 130 | deriving (Show, Eq) 131 | 132 | data GatherSettings 133 | = GatherSettings 134 | deriving (Show, Eq) 135 | 136 | data GenGatherWrapperScriptSettings 137 | = GenGatherWrapperScriptSettings 138 | deriving (Show, Eq) 139 | 140 | newtype ListRecentDirSettings 141 | = ListRecentDirSettings 142 | { lrdSetBypassCache :: Bool 143 | } 144 | deriving (Show, Eq) 145 | 146 | newtype ChangeDirSettings 147 | = ChangeDirSettings 148 | { changeDirSetIdx :: Int 149 | } 150 | deriving (Show, Eq) 151 | 152 | data GenChangeWrapperScriptSettings 153 | = GenChangeWrapperScriptSettings 154 | deriving (Show, Eq) 155 | 156 | data SuggestAliasSettings 157 | = SuggestAliasSettings 158 | deriving (Show, Eq) 159 | 160 | newtype SyncSettings 161 | = SyncSettings 162 | { syncSettingsRemoteStorage :: RemoteStorage 163 | } 164 | deriving (Show, Eq) 165 | 166 | newtype RegisterSettings 167 | = RegisterSettings 168 | { registerSettingsRemoteStorage :: RemoteStorage 169 | } 170 | deriving (Show, Eq) 171 | 172 | data Settings 173 | = Settings 174 | { setCacheDir :: Path Abs Dir, 175 | setDataDir :: Path Abs Dir 176 | } 177 | deriving (Show, Eq, Generic) 178 | 179 | instance NFData Settings 180 | 181 | data RemoteStorage 182 | = RemoteStorage 183 | { remoteStorageBaseUrl :: BaseUrl, 184 | remoteStorageUsername :: Username, 185 | remoteStoragePassword :: Text 186 | } 187 | deriving (Show, Eq) 188 | -------------------------------------------------------------------------------- /hastory-cli/test/Hastory/Cli/OptParse/TypesSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Hastory.Cli.OptParse.TypesSpec 4 | ( spec, 5 | ) 6 | where 7 | 8 | import Data.Aeson (Result (..), fromJSON) 9 | import Data.Yaml (decodeThrow) 10 | import Hastory.Data 11 | import Servant.Client 12 | import TestImport hiding (Failure, Result, Success) 13 | 14 | spec :: Spec 15 | spec = 16 | describe "YamlSchema Configuration" $ do 17 | it "is an 'partial' Configuration when user provides SOME fields" $ do 18 | value <- Data.Yaml.decodeThrow "username: steven" 19 | fromJSON value 20 | `shouldBe` Success (emptyConfiguration {configStorageUsername = Just (Username "steven")}) 21 | it "is a 'full' Configuration when user provides ALL fields" $ do 22 | value <- 23 | Data.Yaml.decodeThrow 24 | "username: steven\npassword: Passw0rd\nurl: api.example.com\ncache-dir: ~/home\nbypass-cache: true" 25 | url <- parseBaseUrl "api.example.com" 26 | fromJSON value 27 | `shouldBe` Success 28 | ( emptyConfiguration 29 | { configCacheDir = Just "~/home", 30 | configStorageServer = Just url, 31 | configStorageUsername = Just (Username "steven"), 32 | configStoragePassword = Just "Passw0rd", 33 | configLrdBypassCache = Just True 34 | } 35 | ) 36 | it "is an error when user provides the wrong type for a field" $ do 37 | value <- Data.Yaml.decodeThrow "url: 1" 38 | (fromJSON value :: Result Configuration) `shouldSatisfy` isConfigParserError 39 | context "cache-dir" $ do 40 | it "parses correctly when cache-dir key is not provided" $ do 41 | value <- Data.Yaml.decodeThrow "url: api.example.com" 42 | let Success config = fromJSON value 43 | configCacheDir config `shouldBe` Nothing 44 | it "parses correctly when cache-dir key is provided and value is valid" $ do 45 | value <- Data.Yaml.decodeThrow "cache-dir: ~/home" 46 | let Success config = fromJSON value 47 | configCacheDir config `shouldBe` Just "~/home" 48 | it "is an error when cache-dir key is provided but value is invalid" $ do 49 | value <- Data.Yaml.decodeThrow "cache-dir: {}" 50 | (fromJSON value :: Result Configuration) `shouldSatisfy` isConfigParserError 51 | it "is an error when cache-dir key is provided but value is empty" $ do 52 | value <- Data.Yaml.decodeThrow "cache-dir: " 53 | let Success config = fromJSON value 54 | configCacheDir config `shouldBe` Nothing 55 | context "data-dir" $ do 56 | it "parses correctly when data-dir key is not provided" $ do 57 | value <- Data.Yaml.decodeThrow "url: api.example.com" 58 | let Success config = fromJSON value 59 | configDataDir config `shouldBe` Nothing 60 | it "parses correctly when data-dir key is provided and value is valid" $ do 61 | value <- Data.Yaml.decodeThrow "data-dir: ~/home" 62 | let Success config = fromJSON value 63 | configDataDir config `shouldBe` Just "~/home" 64 | it "is an error when data-dir key is provided but value is invalid" $ do 65 | value <- Data.Yaml.decodeThrow "data-dir: {}" 66 | (fromJSON value :: Result Configuration) `shouldSatisfy` isConfigParserError 67 | it "is an error when data-dir key is provided but value is empty" $ do 68 | value <- Data.Yaml.decodeThrow "data-dir: " 69 | let Success config = fromJSON value 70 | configDataDir config `shouldBe` Nothing 71 | context "url" $ do 72 | it "parses correctly when url key is not provided" $ do 73 | value <- Data.Yaml.decodeThrow "password: Passw0rd" 74 | let Success config = fromJSON value 75 | configStorageServer config `shouldBe` Nothing 76 | it "parses correctly when url key is provided" $ do 77 | value <- Data.Yaml.decodeThrow "url: api.example.com" 78 | let Success config = fromJSON value 79 | url <- parseBaseUrl "api.example.com" 80 | configStorageServer config `shouldBe` Just url 81 | it "is an error when url key is provided and value is invalid" $ do 82 | value <- Data.Yaml.decodeThrow "url: ftp://1" 83 | (fromJSON value :: Result Configuration) `shouldSatisfy` isConfigParserError 84 | context "username" $ do 85 | it "parses correctly when username key is not provided" $ do 86 | value <- Data.Yaml.decodeThrow "password: Passw0rd" 87 | let Success config = fromJSON value 88 | configStorageUsername config `shouldBe` Nothing 89 | it "parses correctly when username key is provided and value is valid" $ do 90 | value <- Data.Yaml.decodeThrow "username: steven" 91 | let Success config = fromJSON value 92 | username <- parseUsername "steven" 93 | configStorageUsername config `shouldBe` Just username 94 | it "is an error when username key is provided and value is invalid" $ do 95 | value <- Data.Yaml.decodeThrow "username: s" 96 | (fromJSON value :: Result Configuration) `shouldSatisfy` isConfigParserError 97 | context "password" $ do 98 | it "parses correctly when password key is not provided" $ do 99 | value <- Data.Yaml.decodeThrow "url: api.example.com" 100 | let Success config = fromJSON value 101 | configStoragePassword config `shouldBe` Nothing 102 | it "parses correctly when password key is provided and value is valid" $ do 103 | value <- Data.Yaml.decodeThrow "password: Passw0rd" 104 | let Success config = fromJSON value 105 | configStoragePassword config `shouldBe` Just "Passw0rd" 106 | context "bypass-cache" $ do 107 | it "parses correctly when file contains 'bypass-cache'" $ do 108 | value <- Data.Yaml.decodeThrow "bypass-cache: true" 109 | fromJSON value `shouldBe` Success (emptyConfiguration {configLrdBypassCache = Just True}) 110 | it "parses correctly when file contains 'no-bypass-cache'" $ do 111 | value <- Data.Yaml.decodeThrow "bypass-cache: false" 112 | fromJSON value `shouldBe` Success (emptyConfiguration {configLrdBypassCache = Just False}) 113 | it "parses correctly when file does not contain 'bypass-cache key'" $ do 114 | value <- Data.Yaml.decodeThrow "password: Passw0rd" 115 | fromJSON value 116 | `shouldBe` Success 117 | ( emptyConfiguration 118 | { configStoragePassword = Just "Passw0rd", 119 | configLrdBypassCache = Nothing 120 | } 121 | ) 122 | it "is an error if key exists but any other value is provied" $ do 123 | value <- Data.Yaml.decodeThrow "bypass-cache: invalid" 124 | (fromJSON value :: Result Configuration) `shouldSatisfy` isConfigParserError 125 | 126 | isConfigParserError :: Result a -> Bool 127 | isConfigParserError (Error _) = True 128 | isConfigParserError _ = False 129 | 130 | emptyConfiguration :: Configuration 131 | emptyConfiguration = 132 | Configuration 133 | { configCacheDir = Nothing, 134 | configStorageServer = Nothing, 135 | configStorageUsername = Nothing, 136 | configStoragePassword = Nothing, 137 | configLrdBypassCache = Nothing, 138 | configDataDir = Nothing 139 | } 140 | -------------------------------------------------------------------------------- /hastory-server/src/Hastory/Server/OptParse.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE QuasiQuotes #-} 4 | {-# LANGUAGE RecordWildCards #-} 5 | {-# LANGUAGE TypeApplications #-} 6 | 7 | module Hastory.Server.OptParse where 8 | 9 | import Control.Monad 10 | import Data.Maybe 11 | import qualified Data.Text as T 12 | import Data.Yaml 13 | import qualified Env 14 | import GHC.Generics (Generic) 15 | import Options.Applicative as OptParse 16 | import qualified Options.Applicative.Help as OptParse (string) 17 | import Path 18 | import Path.IO 19 | import Text.Read 20 | import YamlParse.Applicative as YamlParse 21 | 22 | data Instructions = Instructions Dispatch Settings deriving (Show, Eq, Generic) 23 | 24 | newtype Dispatch = DispatchServe ServeSettings deriving (Show, Eq, Generic) 25 | 26 | data Settings = Settings deriving (Show, Eq, Generic) 27 | 28 | data ServeSettings 29 | = ServeSettings 30 | { serveSettingsPort :: Int, 31 | serveSettingsLogFile :: Path Abs File, 32 | serveSettingsKeyFile :: Path Abs File 33 | } 34 | deriving (Show, Eq, Generic) 35 | 36 | data Arguments = Arguments Command Flags deriving (Show, Eq, Generic) 37 | 38 | newtype Command = CommandServe ServeArgs deriving (Show, Eq, Generic) 39 | 40 | data ServeArgs 41 | = ServeArgs 42 | { serveArgsPort :: Maybe Int, 43 | serveArgsLogFile :: Maybe FilePath, 44 | serveArgsKeyFile :: Maybe FilePath 45 | } 46 | deriving (Show, Eq, Generic) 47 | 48 | newtype Flags = Flags {flagsConfigFile :: Maybe FilePath} deriving (Show, Eq, Generic) 49 | 50 | data Environment 51 | = Environment 52 | { envPort :: Maybe Int, 53 | envLogFile :: Maybe FilePath, 54 | envKeyFile :: Maybe FilePath, 55 | envConfigFile :: Maybe FilePath 56 | } 57 | deriving (Show, Eq, Generic) 58 | 59 | data Configuration 60 | = Configuration 61 | { configPort :: Maybe Int, 62 | configLogFile :: Maybe FilePath, 63 | configKeyFile :: Maybe FilePath 64 | } 65 | deriving (Show, Eq, Generic) 66 | 67 | instance FromJSON Configuration where 68 | parseJSON = viaYamlSchema 69 | 70 | instance YamlSchema Configuration where 71 | yamlSchema = 72 | objectParser 73 | "Configuration" 74 | ( Configuration 75 | <$> optionalField "port" "Port to start server on." 76 | <*> optionalField "log" "File to save logs to." 77 | <*> optionalField "key" "File to read / write JWK key from / to." 78 | ) 79 | 80 | getInstructions :: IO Instructions 81 | getInstructions = do 82 | args@(Arguments _ flags) <- getArguments 83 | env <- getEnvironment 84 | config <- getConfiguration flags env 85 | combineToInstructions args env config 86 | 87 | getArguments :: IO Arguments 88 | getArguments = customExecParser prefs_ argParser 89 | 90 | getEnvironment :: IO Environment 91 | getEnvironment = Env.parse (Env.header "Environment") environmentParser 92 | 93 | combineToInstructions :: Arguments -> Environment -> Maybe Configuration -> IO Instructions 94 | combineToInstructions (Arguments cmd _flags) Environment {..} mConf = Instructions <$> dispatch <*> settings 95 | where 96 | dispatch = 97 | case cmd of 98 | CommandServe ServeArgs {..} -> do 99 | let serveSettingsPort = fromMaybe 8000 (serveArgsPort <|> envPort <|> mc configPort) 100 | serveSettingsLogFile <- 101 | maybe getDefaultLogFile resolveFile' (serveArgsLogFile <|> envLogFile <|> mc configLogFile) 102 | serveSettingsKeyFile <- 103 | maybe getDefaultKeyFile resolveFile' (serveArgsKeyFile <|> envKeyFile <|> mc configKeyFile) 104 | pure $ DispatchServe (ServeSettings {..}) 105 | settings = pure Settings 106 | mc f = mConf >>= f 107 | 108 | getDefaultKeyFile :: IO (Path Abs File) 109 | getDefaultKeyFile = do 110 | xdgConfigDir <- getXdgDir XdgData (Just [reldir|hastory-server|]) 111 | resolveFile xdgConfigDir "hastory.key" 112 | 113 | getDefaultLogFile :: IO (Path Abs File) 114 | getDefaultLogFile = do 115 | xdgConfigDir <- getXdgDir XdgData (Just [reldir|hastory-server|]) 116 | resolveFile xdgConfigDir "hastory.logs" 117 | 118 | getDefaultConfigFile :: IO (Path Abs File) 119 | getDefaultConfigFile = do 120 | xdgConfigDir <- getXdgDir XdgConfig (Just [reldir|hastory-server|]) 121 | resolveFile xdgConfigDir "config.yaml" 122 | 123 | getConfiguration :: Flags -> Environment -> IO (Maybe Configuration) 124 | getConfiguration Flags {..} Environment {..} = 125 | case flagsConfigFile <|> envConfigFile of 126 | Nothing -> getDefaultConfigFile >>= YamlParse.readConfigFile 127 | Just cf -> resolveFile' cf >>= YamlParse.readConfigFile 128 | 129 | prefs_ :: OptParse.ParserPrefs 130 | prefs_ = OptParse.defaultPrefs {OptParse.prefShowHelpOnError = True, OptParse.prefShowHelpOnEmpty = True} 131 | 132 | argParser :: OptParse.ParserInfo Arguments 133 | argParser = 134 | OptParse.info 135 | (OptParse.helper <*> parseArgs) 136 | (OptParse.fullDesc <> OptParse.footerDoc (Just $ OptParse.string footerStr)) 137 | where 138 | footerStr = 139 | unlines 140 | [ Env.helpDoc environmentParser, 141 | "", 142 | "Configuration file format:", 143 | T.unpack (YamlParse.prettySchemaDoc @Configuration) 144 | ] 145 | 146 | parseArgs :: OptParse.Parser Arguments 147 | parseArgs = Arguments <$> parseCommand <*> parseFlags 148 | 149 | parseCommand :: OptParse.Parser Command 150 | parseCommand = 151 | OptParse.hsubparser $ 152 | mconcat 153 | [ OptParse.command "serve" $ CommandServe <$> parseCommandServe 154 | ] 155 | 156 | parseCommandServe :: OptParse.ParserInfo ServeArgs 157 | parseCommandServe = 158 | OptParse.info 159 | (OptParse.helper <*> parseServeArgs) 160 | (OptParse.fullDesc <> OptParse.progDesc "Start the server.") 161 | 162 | parseServeArgs :: OptParse.Parser ServeArgs 163 | parseServeArgs = ServeArgs <$> parsePort <*> parseLogFile <*> parseKeyFile 164 | where 165 | parsePort = optional $ option auto (short 'p' <> long "port" <> metavar "PORT" <> help "The port at which the server will be available.") 166 | parseLogFile = optional $ strOption (short 'l' <> long "log" <> metavar "LOG" <> help "The file to which server logs will be written.") 167 | parseKeyFile = optional $ strOption (short 'k' <> long "key" <> metavar "KEY" <> help "The file to which server keys will be read from / written to.") 168 | 169 | parseFlags :: OptParse.Parser Flags 170 | parseFlags = Flags <$> configFileParser 171 | where 172 | configFileParser :: OptParse.Parser (Maybe FilePath) 173 | configFileParser = optional $ strOption (short 'c' <> long "config-file" <> metavar "FILEPATH" <> help "Path to an alternative config file.") 174 | 175 | environmentParser :: Env.Parser Env.Error Environment 176 | environmentParser = 177 | Env.prefixed "HASTORY_SERVER_" $ 178 | Environment 179 | <$> Env.var readNum "PORT" (Env.help "The port at which the server will be available." <> Env.def Nothing) 180 | <*> Env.var (pure . Just <=< Env.nonempty) "LOG" (Env.help "The file to which server logs will be written." <> Env.def Nothing) 181 | <*> Env.var (pure . Just <=< Env.nonempty) "KEY" (Env.help "The file to which server keys will be read from / written to." <> Env.def Nothing) 182 | <*> Env.var (pure . Just <=< Env.nonempty) "CONFIG_FILE" (Env.help "Path to an alternative config file." <> Env.def Nothing) 183 | where 184 | readNum :: String -> Either Env.Error (Maybe Int) 185 | readNum s = case readMaybe s of 186 | Nothing -> Left $ Env.UnreadError (unwords ["Could not parse '", s, "' into a number"]) 187 | Just i -> Right (Just i) 188 | -------------------------------------------------------------------------------- /hastory-cli/src/Hastory/Cli/OptParse.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE QuasiQuotes #-} 2 | {-# LANGUAGE RecordWildCards #-} 3 | {-# LANGUAGE TypeApplications #-} 4 | 5 | module Hastory.Cli.OptParse 6 | ( combineToInstructions, 7 | getConfiguration, 8 | getInstructions, 9 | envParser, 10 | runArgumentsParser, 11 | Instructions (..), 12 | Dispatch (..), 13 | Settings (..), 14 | ) 15 | where 16 | 17 | import Control.Monad 18 | import Data.Maybe (fromMaybe) 19 | import qualified Data.Text as T 20 | import qualified Env 21 | import Hastory.Cli.OptParse.Types 22 | import Hastory.Data 23 | import Options.Applicative 24 | import qualified Options.Applicative.Help.Pretty as OptParseHelp 25 | import Path.IO 26 | ( XdgDirectory (..), 27 | getXdgDir, 28 | resolveDir', 29 | resolveFile, 30 | resolveFile', 31 | ) 32 | import Servant.Client.Core.Reexport (parseBaseUrl) 33 | import System.Environment (getArgs) 34 | import System.Exit (die) 35 | import YamlParse.Applicative hiding (Parser) 36 | 37 | getInstructions :: IO Instructions 38 | getInstructions = do 39 | Arguments cmd flags <- getArguments 40 | environment <- getEnvironment 41 | defaultConfigFile <- getXdgDir XdgConfig (Just [reldir|hastory|]) >>= flip resolveFile "config.yaml" 42 | mConfig <- getConfiguration defaultConfigFile flags environment 43 | combineToInstructions cmd flags environment mConfig 44 | 45 | combineToInstructions :: Command -> Flags -> Environment -> Maybe Configuration -> IO Instructions 46 | combineToInstructions cmd Flags {..} Environment {..} mConf = 47 | Instructions <$> getDispatch <*> getSettings 48 | where 49 | getDispatch = 50 | case cmd of 51 | CommandGather _ -> pure $ DispatchGather GatherSettings 52 | CommandGenGatherWrapperScript _ -> 53 | pure $ DispatchGenGatherWrapperScript GenGatherWrapperScriptSettings 54 | CommandListRecentDirs ListRecentDirFlags {..} -> 55 | let lrdBypassCache = lrdArgBypassCache <|> envLrdBypassCache <|> mc configLrdBypassCache 56 | in pure $ 57 | DispatchListRecentDirs 58 | ListRecentDirSettings {lrdSetBypassCache = fromMaybe False lrdBypassCache} 59 | CommandChangeDir ChangeDirFlags {..} -> 60 | pure $ DispatchChangeDir ChangeDirSettings {changeDirSetIdx = changeDirFlagsIdx} 61 | CommandGenChangeWrapperScript _ -> 62 | pure $ DispatchGenChangeWrapperScript GenChangeWrapperScriptSettings 63 | CommandSuggestAlias _ -> pure $ DispatchSuggestAlias SuggestAliasSettings 64 | CommandSync syncFlags -> DispatchSync . SyncSettings <$> getRemoteStorage syncFlags 65 | CommandRegister registerFlags -> DispatchRegister . RegisterSettings <$> getRemoteStorage registerFlags 66 | getRemoteStorage :: RemoteStorageFlags -> IO RemoteStorage 67 | getRemoteStorage RemoteStorageFlags {..} = do 68 | remoteStorageBaseUrl <- 69 | case remoteStorageFlagsServer <|> envStorageServer <|> mc configStorageServer of 70 | Nothing -> die "Storage server not configured." 71 | Just baseUrl -> pure baseUrl 72 | remoteStorageUsername <- 73 | case remoteStorageFlagsUsername <|> envStorageUsername <|> mc configStorageUsername of 74 | Nothing -> die "Username not configured." 75 | Just username -> pure username 76 | remoteStoragePassword <- 77 | case remoteStorageFlagsPassword <|> envStoragePassword <|> mc configStoragePassword of 78 | Nothing -> die "Password not configured." 79 | Just pw -> pure pw 80 | pure RemoteStorage {..} 81 | getSettings = do 82 | cacheDir <- 83 | case flagCacheDir <|> envCacheDir <|> mc configCacheDir of 84 | Nothing -> getXdgDir XdgCache (Just [reldir|hastory|]) 85 | Just cd -> resolveDir' cd 86 | dataDir <- 87 | case flagDataDir <|> envDataDir <|> mc configDataDir of 88 | Nothing -> getXdgDir XdgData (Just [reldir|hastory|]) 89 | Just cd -> resolveDir' cd 90 | pure Settings {setCacheDir = cacheDir, setDataDir = dataDir} 91 | mc :: (Configuration -> Maybe a) -> Maybe a 92 | mc func = mConf >>= func 93 | 94 | getConfiguration :: Path Abs File -> Flags -> Environment -> IO (Maybe Configuration) 95 | getConfiguration defaultConfigFile Flags {..} Environment {..} = 96 | case flagConfigFile <|> envConfigFile of 97 | Just userProvidedPath -> resolveFile' userProvidedPath >>= readConfigFile 98 | Nothing -> readConfigFile defaultConfigFile 99 | 100 | getArguments :: IO Arguments 101 | getArguments = do 102 | args <- getArgs 103 | let result = runArgumentsParser args 104 | handleParseResult result 105 | 106 | getEnvironment :: IO Environment 107 | getEnvironment = Env.parse (Env.header "hastory") envParser 108 | 109 | envParser :: Env.Parser Env.Error Environment 110 | envParser = 111 | Env.prefixed 112 | "HASTORY_" 113 | ( Environment 114 | <$> Env.var 115 | (pure . Just <=< Env.nonempty) 116 | "CACHE_DIR" 117 | (Env.help "The cache directory." <> Env.def Nothing) 118 | <*> Env.var 119 | (pure . Just <=< Env.nonempty) 120 | "CONFIG_FILE" 121 | (Env.help "Path to a config file." <> Env.def Nothing) 122 | <*> Env.var 123 | baseUrlParser 124 | "STORAGE_SERVER_URL" 125 | (Env.help "URL of the sync server." <> Env.def Nothing) 126 | <*> Env.var 127 | usernameParser 128 | "STORAGE_SERVER_USERNAME" 129 | (Env.help "Username for the sync server." <> Env.def Nothing) 130 | <*> Env.var 131 | (pure . Just <=< Env.nonempty) 132 | "STORAGE_SERVER_PASSWORD" 133 | (Env.help "Password for the sync server." <> Env.def Nothing) 134 | <*> Env.var 135 | (fmap Just . Env.auto) 136 | "BYPASS_CACHE" 137 | (Env.help "Always recompute the recent directory options." <> Env.def Nothing) 138 | <*> Env.var 139 | (pure . Just <=< Env.nonempty) 140 | "DATA_DIR" 141 | (Env.help "Data directory for hastory." <> Env.def Nothing) 142 | ) 143 | where 144 | baseUrlParser unparsedUrl = 145 | maybe (Left $ Env.UnreadError unparsedUrl) (Right . Just) (parseBaseUrl unparsedUrl) 146 | usernameParser username = 147 | maybe (Left $ Env.UnreadError username) (pure . Just) (parseUsername $ T.pack username) 148 | 149 | runArgumentsParser :: [String] -> ParserResult Arguments 150 | runArgumentsParser = 151 | execParserPure 152 | ( defaultPrefs 153 | { prefShowHelpOnError = True, 154 | prefShowHelpOnEmpty = True 155 | } 156 | ) 157 | argParser 158 | 159 | argParser :: ParserInfo Arguments 160 | argParser = info (helper <*> parseArgs) (fullDesc <> progDesc "Hastory" <> footerDoc footerStr) 161 | where 162 | footerStr = 163 | Just $ 164 | OptParseHelp.string $ 165 | unlines 166 | [ Env.helpDoc envParser, 167 | "", 168 | "Configuration file format:", 169 | T.unpack (prettySchemaDoc @Configuration) 170 | ] 171 | 172 | parseArgs :: Parser Arguments 173 | parseArgs = Arguments <$> parseCommand <*> parseFlags 174 | 175 | parseCommand :: Parser Command 176 | parseCommand = 177 | hsubparser $ 178 | mconcat 179 | [ command "gather" parseCommandGather, 180 | command "generate-gather-wrapper-script" parseGenGatherWrapperScript, 181 | command "change-directory" parseCommandChangeDir, 182 | command "list-recent-directories" parseCommandListRecentDirs, 183 | command "generate-change-directory-wrapper-script" parseGenChangeDirectoryWrapperScript, 184 | command "suggest-alias" parseSuggestAlias, 185 | command "sync" parseSync, 186 | command "register" parseRegister 187 | ] 188 | 189 | parseCommandGather :: ParserInfo Command 190 | parseCommandGather = 191 | info 192 | (pure $ CommandGather GatherFlags) 193 | (fullDesc <> progDesc "Read a single command on the standard input.") 194 | 195 | parseGenGatherWrapperScript :: ParserInfo Command 196 | parseGenGatherWrapperScript = 197 | info 198 | (pure $ CommandGenGatherWrapperScript GenGatherWrapperScriptFlags) 199 | (progDesc "Generate the wrapper script to use 'gather'.") 200 | 201 | parseCommandChangeDir :: ParserInfo Command 202 | parseCommandChangeDir = 203 | info 204 | ( CommandChangeDir . ChangeDirFlags 205 | <$> argument 206 | auto 207 | ( mconcat 208 | [ help "The index of the directory to change to, see 'list-recent-directories'.", 209 | metavar "INT" 210 | ] 211 | ) 212 | ) 213 | (progDesc "Output a directory to change to based on the gathered data.") 214 | 215 | parseCommandListRecentDirs :: ParserInfo Command 216 | parseCommandListRecentDirs = 217 | info 218 | ( CommandListRecentDirs 219 | <$> ( ListRecentDirFlags 220 | <$> ( flag' 221 | (Just True) 222 | (mconcat [long "bypass-cache", help "Always recompute the recent directory options."]) 223 | <|> flag' 224 | (Just False) 225 | (mconcat [long "no-bypass-cache", help "Use the recent directory cache when available."]) 226 | <|> pure Nothing 227 | ) 228 | ) 229 | ) 230 | (progDesc "List the directories that were the working directory most often / recently.") 231 | 232 | parseGenChangeDirectoryWrapperScript :: ParserInfo Command 233 | parseGenChangeDirectoryWrapperScript = 234 | info 235 | (pure $ CommandGenChangeWrapperScript GenChangeWrapperScriptFlags) 236 | (progDesc "Generate the wrapper script to use 'change-directory'.") 237 | 238 | parseSuggestAlias :: ParserInfo Command 239 | parseSuggestAlias = 240 | info 241 | (pure $ CommandSuggestAlias SuggestAliasFlags) 242 | (progDesc "Suggest commands for which the user may want to make aliases.") 243 | 244 | parseSync :: ParserInfo Command 245 | parseSync = info (CommandSync <$> remoteStorageParser) (progDesc "Sync the local database with a remote server.") 246 | 247 | parseRegister :: ParserInfo Command 248 | parseRegister = info (CommandRegister <$> remoteStorageParser) (progDesc "Register with a remote server.") 249 | 250 | remoteStorageParser :: Parser RemoteStorageFlags 251 | remoteStorageParser = RemoteStorageFlags <$> remoteStorageFlagServerParser <*> remoteStorageFlagUsernameParser <*> remoteStorageFlagPasswordParser 252 | where 253 | remoteStorageFlagServerParser = 254 | optional $ 255 | option 256 | (maybeReader parseBaseUrl) 257 | (long "storage-server" <> help "Remote storage url." <> metavar "URL") 258 | remoteStorageFlagUsernameParser = 259 | optional $ 260 | option 261 | (maybeReader $ parseUsername . T.pack) 262 | (long "storage-username" <> help "Remote storage username." <> metavar "USERNAME") 263 | remoteStorageFlagPasswordParser = 264 | optional $ 265 | strOption (long "storage-password" <> help "Remote storage password." <> metavar "PASSWORD") 266 | 267 | parseFlags :: Parser Flags 268 | parseFlags = 269 | Flags 270 | <$> optional 271 | ( option 272 | nonEmptyString 273 | (mconcat [long "cache-dir", metavar "FILEPATH", help "The cache directory for hastory."]) 274 | ) 275 | <*> optional 276 | ( option 277 | nonEmptyString 278 | (mconcat [long "config-file", metavar "FILEPATH", help "Path to a config file."]) 279 | ) 280 | <*> optional 281 | ( option 282 | nonEmptyString 283 | (mconcat [long "data-dir", metavar "FILEPATH", help "The data directory for hastory."]) 284 | ) 285 | where 286 | nonEmptyString = 287 | maybeReader $ \s -> 288 | if null s 289 | then Nothing 290 | else Just s 291 | -------------------------------------------------------------------------------- /hastory-cli/test/Hastory/Cli/OptParseSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE QuasiQuotes #-} 3 | 4 | module Hastory.Cli.OptParseSpec 5 | ( spec, 6 | ) 7 | where 8 | 9 | import qualified Data.ByteString as B 10 | import Env 11 | import Hastory.Cli.OptParse 12 | import Hastory.Data 13 | import Options.Applicative 14 | import Servant.Client 15 | import TestImport hiding (Failure, Success) 16 | 17 | spec :: Spec 18 | spec = do 19 | runArgumentsParserSpec 20 | envParserSpec 21 | getConfigurationSpec 22 | combineToInstructionsSpec 23 | 24 | getConfigurationSpec :: Spec 25 | getConfigurationSpec = 26 | describe "getConfigurationSpec" 27 | $ around withDefaultConfigFile 28 | $ do 29 | it "prefers Flags over Environment file" $ \defaultConfigFile -> do 30 | let contentsOfFileInFlags = "url: flag.example.com" 31 | withFile contentsOfFileInFlags $ \path -> do 32 | let flags = emptyFlags {flagConfigFile = Just (toFilePath path)} 33 | environment = emptyEnvironment {envConfigFile = Just "~/randomUser"} 34 | url <- parseBaseUrl "flag.example.com" 35 | mConf <- getConfiguration defaultConfigFile flags environment 36 | mConf `shouldBe` Just (emptyConfiguration {configStorageServer = Just url}) 37 | it "prefers Environment over default file" $ \defaultConfigFile -> do 38 | let contentsOfFileInEnv = "url: environment.example.com" 39 | withFile contentsOfFileInEnv $ \path -> do 40 | let flags = emptyFlags 41 | environment = emptyEnvironment {envConfigFile = Just (toFilePath path)} 42 | url <- parseBaseUrl "environment.example.com" 43 | mConf <- getConfiguration defaultConfigFile flags environment 44 | mConf `shouldBe` Just (emptyConfiguration {configStorageServer = Just url}) 45 | context "Flags and Environment do NOT specify a config" $ do 46 | context "default config file exists" $ do 47 | it "uses the default config file" $ \defaultConfigFile -> do 48 | let defaultConfigContents = "url: default.example.com" 49 | B.writeFile (toFilePath defaultConfigFile) defaultConfigContents 50 | mConf <- getConfiguration defaultConfigFile emptyFlags emptyEnvironment 51 | url <- parseBaseUrl "default.example.com" 52 | mConf `shouldBe` Just (emptyConfiguration {configStorageServer = Just url}) 53 | it "does not parse malformed config files" $ \defaultConfigFile -> do 54 | let defaultConfigContents = "url: 1" 55 | B.writeFile (toFilePath defaultConfigFile) defaultConfigContents 56 | getConfiguration defaultConfigFile emptyFlags emptyEnvironment `shouldThrow` anyException 57 | context "default config file does not exist" 58 | $ it "has 'empty' configuration" 59 | $ \defaultConfigFile -> do 60 | mConf <- getConfiguration defaultConfigFile emptyFlags emptyEnvironment 61 | mConf `shouldBe` Nothing 62 | 63 | type ConfigFileContents = B.ByteString 64 | 65 | withFile :: ConfigFileContents -> (Path Abs File -> Expectation) -> Expectation 66 | withFile contents f = 67 | withSystemTempDir "hastory.yaml" $ \tmpDir -> do 68 | path <- resolveFile tmpDir "hastory.yaml" 69 | B.writeFile (toFilePath path) contents 70 | f path 71 | 72 | withDefaultConfigFile :: (Path Abs File -> Expectation) -> Expectation 73 | withDefaultConfigFile f = 74 | withSystemTempDir "hastory.yaml" $ \tmpDir -> do 75 | path <- resolveFile tmpDir "hastory.config" 76 | f path 77 | 78 | runArgumentsParserSpec :: Spec 79 | runArgumentsParserSpec = describe "runArgumentsParser" (describeFlags >> describeCommand) 80 | 81 | describeFlags :: Spec 82 | describeFlags = 83 | describe "Flags" $ do 84 | context "cache-dir is provided" $ do 85 | it "contains a FilePath when FilePath is provided" $ do 86 | let (Success (Arguments _cmd flags)) = runArgumentsParser args 87 | args = ["gather", "--cache-dir=" <> filePath] 88 | filePath = "~/hastory" 89 | flags `shouldBe` emptyFlags {flagCacheDir = Just filePath} 90 | it "is an error when FilePath is empty" $ do 91 | let res = runArgumentsParser args 92 | args = ["gather", "--cache-dir="] 93 | res `shouldSatisfy` isCliParserFailure 94 | context "data-dir is provided" $ do 95 | it "contains a FilePath when FilePath is provided" $ do 96 | let (Success (Arguments _cmd flags)) = runArgumentsParser args 97 | args = ["gather", "--data-dir=" <> filePath] 98 | filePath = "~/hastory" 99 | flags `shouldBe` emptyFlags {flagDataDir = Just filePath} 100 | it "is an error when FilePath is empty" $ do 101 | let res = runArgumentsParser args 102 | args = ["gather", "--data-dir="] 103 | res `shouldSatisfy` isCliParserFailure 104 | context "config-file is provided" $ do 105 | it "contains a Filepath when FilePath is provided" $ do 106 | let (Success (Arguments _cmd flags)) = runArgumentsParser args 107 | args = ["gather", "--config-file=" <> filePath] 108 | filePath = "~/hastory" 109 | flags `shouldBe` emptyFlags {flagConfigFile = Just filePath} 110 | it "is an error when FilePath is empty" $ do 111 | let res = runArgumentsParser args 112 | args = ["gather", "--config-file="] 113 | res `shouldSatisfy` isCliParserFailure 114 | context "user provides NO flags" 115 | $ it "is an empty Flags data type" 116 | $ do 117 | let (Success (Arguments _cmd flags)) = runArgumentsParser args 118 | args = ["gather"] 119 | flags `shouldBe` emptyFlags 120 | 121 | describeCommand :: Spec 122 | describeCommand = 123 | describe "Command" $ do 124 | context "user provides the 'gather' command" 125 | $ it "parses to CommandGather" 126 | $ do 127 | let (Success (Arguments cmd _flags)) = runArgumentsParser args 128 | args = ["gather"] 129 | cmd `shouldBe` CommandGather GatherFlags 130 | context "user provides the 'generate-gather-wrapper-script' command" 131 | $ it "parses to CommandGenGatherWrapperScript" 132 | $ do 133 | let (Success (Arguments cmd _flags)) = runArgumentsParser args 134 | args = ["generate-gather-wrapper-script"] 135 | cmd `shouldBe` CommandGenGatherWrapperScript GenGatherWrapperScriptFlags 136 | context "user provides the 'change-directory' command" $ do 137 | it "parses to CommandChangeDir when INT is provided" $ do 138 | let (Success (Arguments cmd _flags)) = runArgumentsParser args 139 | args = ["change-directory", "23"] 140 | cmd `shouldBe` CommandChangeDir ChangeDirFlags {changeDirFlagsIdx = 23} 141 | it "fails to parse with NO options" $ do 142 | let res = runArgumentsParser args 143 | args = ["change-directory"] 144 | res `shouldSatisfy` isCliParserFailure 145 | it "fails to parse when value provided is not an INT" $ do 146 | let res = runArgumentsParser args 147 | args = ["change-directory", "invalid"] 148 | res `shouldSatisfy` isCliParserFailure 149 | context "user provides the 'list-recent-directories' command" $ do 150 | it "parses to CommandListRecentDirs without any options" $ do 151 | let (Success (Arguments cmd _flags)) = runArgumentsParser args 152 | args = ["list-recent-directories"] 153 | cmd `shouldBe` CommandListRecentDirs ListRecentDirFlags {lrdArgBypassCache = Nothing} 154 | it "parses to CommandListRecentDirs with bypass-cache" $ do 155 | let (Success (Arguments cmd _flags)) = runArgumentsParser args 156 | args = ["list-recent-directories", "--bypass-cache"] 157 | cmd `shouldBe` CommandListRecentDirs ListRecentDirFlags {lrdArgBypassCache = Just True} 158 | it "parses to CommandListRecentDirs with --no-bypass-cache" $ do 159 | let (Success (Arguments cmd _flags)) = runArgumentsParser args 160 | args = ["list-recent-directories", "--no-bypass-cache"] 161 | cmd `shouldBe` CommandListRecentDirs ListRecentDirFlags {lrdArgBypassCache = Just False} 162 | it "fails to parse when option is invalid" $ do 163 | let res = runArgumentsParser args 164 | args = ["list-recent-directories", "--invalid"] 165 | res `shouldSatisfy` isCliParserFailure 166 | context "user provides the 'generate-change-directory-wrapper-script' command" 167 | $ it "parses to CommandGenChangeWrapperScript" 168 | $ do 169 | let (Success (Arguments cmd _flags)) = runArgumentsParser args 170 | args = ["generate-change-directory-wrapper-script"] 171 | cmd `shouldBe` CommandGenChangeWrapperScript GenChangeWrapperScriptFlags 172 | context "user provides the 'suggest-alias' command" 173 | $ it "parses to CommandSuggestAlias" 174 | $ do 175 | let (Success (Arguments cmd _flags)) = runArgumentsParser args 176 | args = ["suggest-alias"] 177 | cmd `shouldBe` CommandSuggestAlias SuggestAliasFlags 178 | context "user provides the 'sync' command" 179 | $ it "parses to CommandSync" 180 | $ do 181 | url <- parseBaseUrl "hastory.cs-syd.eu" 182 | let (Success (Arguments cmd _flags)) = runArgumentsParser args 183 | args = 184 | [ "sync", 185 | "--storage-server=hastory.cs-syd.eu", 186 | "--storage-username=steven", 187 | "--storage-password=letmein" 188 | ] 189 | expectedSyncFlags = RemoteStorageFlags (Just url) (Just $ Username "steven") (Just "letmein") 190 | cmd `shouldBe` CommandSync expectedSyncFlags 191 | context "user provides the 'register' command" 192 | $ it "parses to CommandRegister" 193 | $ do 194 | url <- parseBaseUrl "hastory.cs-syd.eu" 195 | let (Success (Arguments cmd _flags)) = runArgumentsParser args 196 | args = 197 | [ "register", 198 | "--storage-server=hastory.cs-syd.eu", 199 | "--storage-username=steven", 200 | "--storage-password=letmein" 201 | ] 202 | expectedRegisterFlags = RemoteStorageFlags (Just url) (Just $ Username "steven") (Just "letmein") 203 | cmd `shouldBe` CommandRegister expectedRegisterFlags 204 | 205 | envParserSpec :: Spec 206 | envParserSpec = 207 | describe "envParser" $ do 208 | context "user provides NO environmental variables" 209 | $ it "parses to an empty Environment" 210 | $ do 211 | let res = Env.parsePure envParser [] 212 | res `shouldBe` Right emptyEnvironment 213 | context "users provides ALL environmental variables" 214 | $ it "parses to a full Environment" 215 | $ do 216 | let url = "api.example.com" 217 | parsedUrl <- parseBaseUrl url 218 | let res = Env.parsePure envParser fullEnvironment 219 | fullEnvironment = 220 | [ ("HASTORY_CACHE_DIR", "~/home"), 221 | ("HASTORY_CONFIG_FILE", "~/home/.hastory.yaml"), 222 | ("HASTORY_STORAGE_SERVER_URL", url), 223 | ("HASTORY_STORAGE_SERVER_USERNAME", "steven"), 224 | ("HASTORY_STORAGE_SERVER_PASSWORD", "Passw0rd"), 225 | ("HASTORY_BYPASS_CACHE", "True") 226 | ] 227 | res 228 | `shouldBe` Right 229 | emptyEnvironment 230 | { envCacheDir = Just "~/home", 231 | envConfigFile = Just "~/home/.hastory.yaml", 232 | envStorageServer = Just parsedUrl, 233 | envStorageUsername = Just (Username "steven"), 234 | envStoragePassword = Just "Passw0rd", 235 | envLrdBypassCache = Just True 236 | } 237 | context "users provides SOME environmental variables" $ do 238 | it "successfully parses to an Environment" $ do 239 | let res = Env.parsePure envParser [("HASTORY_CACHE_DIR", "~/home")] 240 | res `shouldBe` Right emptyEnvironment {envCacheDir = Just "~/home"} 241 | context "CACHE_DIR is set in environment" $ do 242 | it "parses correctly when CACHE_DIR is valid" $ do 243 | let res = Env.parsePure envParser [("HASTORY_CACHE_DIR", "~/home")] 244 | res `shouldBe` Right emptyEnvironment {envCacheDir = Just "~/home"} 245 | it "is an error when CACHE_DIR is invalid" $ do 246 | let res = Env.parsePure envParser [("HASTORY_CACHE_DIR", "")] 247 | res `shouldSatisfy` isEnvParserFailure 248 | context "DATA_DIR is set in environment" $ do 249 | it "parses correctly when DATA_DIR is valid" $ do 250 | let res = Env.parsePure envParser [("HASTORY_DATA_DIR", "~/home")] 251 | res `shouldBe` Right emptyEnvironment {envDataDir = Just "~/home"} 252 | it "is an error when DATA_DIR is invalid" $ do 253 | let res = Env.parsePure envParser [("HASTORY_DATA_DIR", "")] 254 | res `shouldSatisfy` isEnvParserFailure 255 | context "CONFIG_FILE is set in environment" $ do 256 | it "parses correctly when CONFIG_FILE is valid" $ do 257 | let res = Env.parsePure envParser [("HASTORY_CONFIG_FILE", "~/home")] 258 | res `shouldBe` Right emptyEnvironment {envConfigFile = Just "~/home"} 259 | it "is an error when CONFIG_FILE is invalid" $ do 260 | let res = Env.parsePure envParser [("HASTORY_CONFIG_FILE", "")] 261 | res `shouldSatisfy` isEnvParserFailure 262 | context "STORAGE_SERVER_URL is set in environment" $ do 263 | it "parses STORAGE_SERVER_URL correctly" $ do 264 | let res = Env.parsePure envParser [("HASTORY_STORAGE_SERVER_URL", "api.example.com")] 265 | url <- parseBaseUrl "api.example.com" 266 | res `shouldBe` Right emptyEnvironment {envStorageServer = Just url} 267 | it "is an error when STORAGE_SERVER_URL is invalid" $ do 268 | let res = Env.parsePure envParser [("HASTORY_STORAGE_SERVER_URL", "ftps://1")] 269 | res `shouldSatisfy` isEnvParserFailure 270 | context "STORAGE_SERVER_USERNAME is set in environment" $ do 271 | it "parses STORAGE_SERVER_USERNAME correctly" $ do 272 | let res = Env.parsePure envParser [("HASTORY_STORAGE_SERVER_USERNAME", "steven")] 273 | username <- parseUsername "steven" 274 | res `shouldBe` Right emptyEnvironment {envStorageUsername = Just username} 275 | it "is an error when STORAGE_SERVER_USERNAME is invalid" $ do 276 | let res = Env.parsePure envParser [("HASTORY_STORAGE_SERVER_USERNAME", "s")] 277 | res `shouldSatisfy` isEnvParserFailure 278 | context "STORAGE_SERVER_PASSWORD is set in environment" $ do 279 | it "parses STORAGE_SERVER_PASSWORD correctly" $ do 280 | let res = Env.parsePure envParser [("HASTORY_STORAGE_SERVER_PASSWORD", "Passw0rd")] 281 | res `shouldBe` Right emptyEnvironment {envStoragePassword = Just "Passw0rd"} 282 | it "is an error when STORAGE_SERVER_PASSWORD is invalid" $ do 283 | let res = Env.parsePure envParser [("HASTORY_STORAGE_SERVER_PASSWORD", "")] 284 | res `shouldSatisfy` isEnvParserFailure 285 | context "BYPASS_CACHE is set in environment" $ do 286 | it "parses True correctly when the env var is set to True" $ do 287 | let res = Env.parsePure envParser [("HASTORY_BYPASS_CACHE", "True")] 288 | res `shouldBe` Right emptyEnvironment {envLrdBypassCache = Just True} 289 | it "parses False correctly when the envvar is not set" $ do 290 | let res = Env.parsePure envParser [("HASTORY_BYPASS_CACHE", "False")] 291 | res `shouldBe` Right emptyEnvironment {envLrdBypassCache = Just False} 292 | it "is an error when HASTORY_BYPASS_CACHE is invalid" $ do 293 | let res = Env.parsePure envParser [("HASTORY_BYPASS_CACHE", "hello")] 294 | res `shouldSatisfy` isEnvParserFailure 295 | 296 | combineToInstructionsSpec :: Spec 297 | combineToInstructionsSpec = 298 | describe "combineToInstructions" $ do 299 | context "setCacheDir" $ do 300 | it "prefers Flags over Environment" $ do 301 | let flags = emptyFlags {flagCacheDir = Just stevenHomeDir} 302 | stevenHomeDir = "/home/steven" 303 | env = emptyEnvironment {envCacheDir = Just "/home/chris"} 304 | stevenAbsDir <- resolveDir' stevenHomeDir 305 | Instructions _ settings <- 306 | combineToInstructions 307 | (CommandGenGatherWrapperScript GenGatherWrapperScriptFlags) 308 | flags 309 | env 310 | Nothing 311 | setCacheDir settings `shouldBe` stevenAbsDir 312 | it "falls back to Environment cache if Flags cache is missing" $ do 313 | let flags = emptyFlags 314 | env = emptyEnvironment {envCacheDir = Just chrisHomeDir} 315 | chrisHomeDir = "/home/chris" 316 | chrisAbsDir <- resolveDir' chrisHomeDir 317 | Instructions _ settings <- 318 | combineToInstructions 319 | (CommandGenGatherWrapperScript GenGatherWrapperScriptFlags) 320 | flags 321 | env 322 | Nothing 323 | setCacheDir settings `shouldBe` chrisAbsDir 324 | it "falls back to Config when Flags / Environment is missing" $ do 325 | let stevenHomeDir = "/home/steven" 326 | stevenAbsDir <- resolveDir' stevenHomeDir 327 | Instructions _ settings <- 328 | combineToInstructions 329 | (CommandGenGatherWrapperScript GenGatherWrapperScriptFlags) 330 | emptyFlags 331 | emptyEnvironment 332 | (Just (emptyConfiguration {configCacheDir = Just stevenHomeDir})) 333 | setCacheDir settings `shouldBe` stevenAbsDir 334 | it "has default when Configuration / Flags / Environment / Config cache is missing" $ do 335 | defaultCacheDir <- getXdgDir XdgCache (Just [reldir|hastory|]) 336 | defaultDataDir <- getXdgDir XdgData (Just [reldir|hastory|]) 337 | Instructions _ settings <- 338 | combineToInstructions 339 | (CommandGenGatherWrapperScript GenGatherWrapperScriptFlags) 340 | emptyFlags 341 | emptyEnvironment 342 | Nothing 343 | settings `shouldBe` Settings defaultCacheDir defaultDataDir 344 | describe "CommandGenGatherWrapperScript" 345 | $ it "is DispatchGenGatherWrapperScript with GenGatherWrapperScriptSettings" 346 | $ do 347 | let cmd = CommandGenGatherWrapperScript GenGatherWrapperScriptFlags 348 | Instructions dispatch _settings <- 349 | combineToInstructions cmd emptyFlags emptyEnvironment Nothing 350 | dispatch `shouldBe` DispatchGenGatherWrapperScript GenGatherWrapperScriptSettings 351 | 352 | emptyFlags :: Flags 353 | emptyFlags = Flags {flagCacheDir = Nothing, flagConfigFile = Nothing, flagDataDir = Nothing} 354 | 355 | emptyConfiguration :: Configuration 356 | emptyConfiguration = 357 | Configuration 358 | { configCacheDir = Nothing, 359 | configStorageServer = Nothing, 360 | configStorageUsername = Nothing, 361 | configStoragePassword = Nothing, 362 | configLrdBypassCache = Nothing, 363 | configDataDir = Nothing 364 | } 365 | 366 | emptyEnvironment :: Environment 367 | emptyEnvironment = 368 | Environment 369 | { envCacheDir = Nothing, 370 | envConfigFile = Nothing, 371 | envStorageServer = Nothing, 372 | envStorageUsername = Nothing, 373 | envStoragePassword = Nothing, 374 | envLrdBypassCache = Nothing, 375 | envDataDir = Nothing 376 | } 377 | 378 | isCliParserFailure :: ParserResult a -> Bool 379 | isCliParserFailure (Failure _) = True 380 | isCliParserFailure _ = False 381 | 382 | isEnvParserFailure :: Either e a -> Bool 383 | isEnvParserFailure (Left _) = True 384 | isEnvParserFailure _ = False 385 | --------------------------------------------------------------------------------