diff --git a/.travis.yml b/.travis.yml --- a/.travis.yml +++ b/.travis.yml @@ -11,7 +11,6 @@ # Use new container infrastructure to enable caching sudo: false -# Do not choose a language; we provide our own build tools. language: generic # Caching so the next build will be fast too. @@ -40,10 +39,10 @@ - env: BUILD=cabal GHCVER=8.4.3 CABALVER=2.2 HAPPYVER=1.19.5 ALEXVER=3.1.7 compiler: ": #GHC 8.4.3" addons: {apt: {packages: [cabal-install-2.2,ghc-8.4.3,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} - - # Build with the newest GHC and cabal-install. This is an accepted failure, - # see below. - - env: BUILD=cabal GHCVER=head CABALVER=head HAPPYVER=1.19.5 ALEXVER=3.1.7 + - env: BUILD=cabal-new GHCVER=8.6.3 CABALVER=2.4 HAPPYVER=1.19.5 ALEXVER=3.1.7 + compiler: ": #GHC 8.6.3" + addons: {apt: {packages: [cabal-install-2.4,ghc-8.6.3,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} + - env: BUILD=cabal-new GHCVER=head CABALVER=head HAPPYVER=1.19.5 ALEXVER=3.1.7 compiler: ": #GHC HEAD" addons: {apt: {packages: [cabal-install-head,ghc-head,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} @@ -59,7 +58,8 @@ os: osx allow_failures: - - env: BUILD=cabal GHCVER=head CABALVER=head HAPPYVER=1.19.5 ALEXVER=3.1.7 + - env: BUILD=cabal-new GHCVER=head CABALVER=head HAPPYVER=1.19.5 ALEXVER=3.1.7 + - env: BUILD=cabal-new GHCVER=8.6.3 CABALVER=2.4 HAPPYVER=1.19.5 ALEXVER=3.1.7 before_install: # Using compiler above sets CC to an invalid value, so unset it @@ -69,6 +69,9 @@ - CABALARGS="" - if [ "x$GHCVER" = "xhead" ]; then CABALARGS=--allow-newer; fi +# Workaround for GHC 8.6.3 +- if [ "x$GHCVER" = "x8.6.3" ]; then CABALARGS="--allow-newer=base,lens,containers --ghc-options=-XNoMonadFailDesugaring"; fi + # Download and unpack the stack executable - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$HOME/.local/bin:/opt/alex/$ALEXVER/bin:/opt/happy/$HAPPYVER/bin:$HOME/.cabal/bin:$PATH - mkdir -p ~/.local/bin @@ -80,12 +83,9 @@ travis_retry curl -L https://get.haskellstack.org/stable/linux-x86_64.tar.gz | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack' fi - # Use the more reliable S3 mirror of Hackage mkdir -p $HOME/.cabal - echo 'remote-repo: hackage.haskell.org:http://hackage.fpcomplete.com/' > $HOME/.cabal/config - echo 'remote-repo-cache: $HOME/.cabal/packages' >> $HOME/.cabal/config - - + echo 'remote-repo: hackage.haskell.org:http://hackage.haskell.org/packages/archive' > $HOME/.cabal/config + echo "remote-repo-cache: $HOME/.cabal/packages" >> $HOME/.cabal/config install: - echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]" - if [ -f configure.ac ]; then autoreconf -i; fi @@ -97,24 +97,20 @@ stack --no-terminal --install-ghc $ARGS test --bench --dry-run || ( \ stack --no-terminal $ARGS build cabal-install && \ stack --no-terminal $ARGS solver --update-config) - # Build the dependencies stack --no-terminal --install-ghc $ARGS test --bench --only-dependencies ;; cabal) cabal --version travis_retry cabal update - - # Get the list of packages from the stack.yaml file. Note that - # this will also implicitly run hpack as necessary to generate - # the .cabal files needed by cabal-install. - PACKAGES=$(stack --install-ghc query locals | grep '^ *path' | sed 's@^ *path:@@') - - cabal install --only-dependencies --enable-tests --enable-benchmarks --force-reinstalls --ghc-options=-O0 --reorder-goals --max-backjumps=-1 $CABALARGS $PACKAGES + cabal install --only-dependencies --enable-tests --enable-benchmarks --force-reinstalls --ghc-options=-O0 --reorder-goals --max-backjumps=-1 $CABALARGS ;; + cabal-new) + cabal --version + travis_retry cabal new-update + ;; esac set +ex - script: - | set -ex @@ -123,28 +119,13 @@ stack --no-terminal $ARGS test --bench --no-run-benchmarks --haddock --no-haddock-deps ;; cabal) - cabal install --enable-tests --enable-benchmarks --force-reinstalls --ghc-options=-O0 --reorder-goals --max-backjumps=-1 $CABALARGS $PACKAGES - - ORIGDIR=$(pwd) - for dir in $PACKAGES - do - cd $dir - cabal check || [ "$CABALVER" == "1.16" ] - cabal sdist - PKGVER=$(cabal info . | awk '{print $2;exit}') - SRC_TGZ=$PKGVER.tar.gz - cd dist - tar zxfv "$SRC_TGZ" - cd "$PKGVER" - cabal configure --enable-tests --ghc-options -O0 - cabal build - if [ "$CABALVER" = "1.16" ] || [ "$CABALVER" = "1.18" ]; then - cabal test - else - cabal test --show-details=streaming --log=/dev/stdout - fi - cd $ORIGDIR - done + cabal configure --enable-tests --enable-benchmarks --ghc-options -O0 + cabal build $CABALARGS + cabal test + ;; + cabal-new) + cabal new-build --enable-tests --enable-benchmarks --ghc-options=-O0 $CABALARGS + cabal new-test $CABALARGS ;; esac set +ex diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -12,3 +12,7 @@ * Examples for chapter 6. All examples of expressions processing are moved to folder 'expr'. + +## 0.4 -- 2019-01-20 + +* Examples for chapters 7 and 8. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -33,6 +33,12 @@ stack exec stockquotes -- data/quotes.csv -p -v ``` +### Testing + +``` +stack test +``` + ### Exploring in GHCi ``` @@ -51,8 +57,8 @@ ``` cabal sandbox init -cabal install --only-dependencies -cabal configure +cabal install --only-dependencies --enable-tests +cabal configure --enable-tests cabal build ``` @@ -68,6 +74,14 @@ cabal run stockquotes -- data/quotes.csv -p -v ``` +### Testing + +``` +cabal test +cabal test iplookup-test +``` + + ### Exploring in GHCi ``` @@ -89,5 +103,11 @@ ``` cabal new-build +``` + +### Testing + +``` +cabal new-test ``` diff --git a/data/ipranges.txt b/data/ipranges.txt new file mode 100644 --- /dev/null +++ b/data/ipranges.txt @@ -0,0 +1,5 @@ +192.168.1.3,192.168.10.14 +127.0.0.1,127.0.0.255 +220.41.240.89,220.41.241.115 +4.159.29.233,5.159.30.77 +62.70.22.158,62.70.24.18 diff --git a/data/ssrequests.txt b/data/ssrequests.txt new file mode 100644 --- /dev/null +++ b/data/ssrequests.txt @@ -0,0 +1,6 @@ +2018-11-05 @ Deschutes Hall, Eugene, OR +#xx-xx-a@ZZ +Undisclosed Location +2018-12-32@Santa's Village +South Pole +3 Yurkla Way, Eucla, WA, Australia diff --git a/data/suntimes.config.sample.json b/data/suntimes.config.sample.json new file mode 100644 --- /dev/null +++ b/data/suntimes.config.sample.json @@ -0,0 +1,5 @@ +{ + "email": "some@email", + "agent": "SunTimes (Haskell in Depth/sample code from the book)", + "timeZoneDBkey": "some key" +} diff --git a/data/tests/iplookup/1.iprs b/data/tests/iplookup/1.iprs new file mode 100644 --- /dev/null +++ b/data/tests/iplookup/1.iprs @@ -0,0 +1,8 @@ +9.166.251.217,20.39.180.175 +50.33.43.83,69.2.226.61 +27.191.215.182,39.236.185.129 +68.66.248.16,95.176.114.135 +34.247.148.113,93.161.226.166 +23.173.2.219,55.224.252.1 +11.188.211.24,40.18.226.141 +4.137.106.119,22.197.224.247 diff --git a/data/tests/iplookup/1.ips b/data/tests/iplookup/1.ips new file mode 100644 --- /dev/null +++ b/data/tests/iplookup/1.ips @@ -0,0 +1,3 @@ +68.66.248.20 +127.0.0.1 +40.18.226.141 diff --git a/data/tests/iplookup/1.out b/data/tests/iplookup/1.out new file mode 100644 --- /dev/null +++ b/data/tests/iplookup/1.out @@ -0,0 +1,3 @@ +68.66.248.20: YES +127.0.0.1: NO +40.18.226.141: YES diff --git a/data/tests/iplookup/1.out.golden b/data/tests/iplookup/1.out.golden new file mode 100644 --- /dev/null +++ b/data/tests/iplookup/1.out.golden @@ -0,0 +1,3 @@ +68.66.248.20: YES +127.0.0.1: NO +40.18.226.141: YES diff --git a/data/tests/iplookup/2.iprs b/data/tests/iplookup/2.iprs new file mode 100644 --- /dev/null +++ b/data/tests/iplookup/2.iprs @@ -0,0 +1,100 @@ +76.1.160.41,92.245.162.35 +46.43.66.65,81.59.31.57 +73.185.91.131,119.125.186.221 +26.48.142.134,91.224.28.136 +51.49.72.215,99.88.227.34 +15.84.76.121,32.57.32.101 +42.255.174.226,46.246.43.83 +21.245.153.209,22.61.70.193 +11.249.92.58,47.177.160.180 +74.5.173.234,93.21.231.101 +0.194.174.99,33.32.11.61 +51.205.97.41,84.40.245.53 +23.217.194.25,76.109.9.144 +45.116.124.67,100.43.216.78 +36.173.46.88,87.231.202.165 +70.33.146.117,123.155.10.175 +71.175.29.72,109.89.194.20 +0.253.220.160,50.149.74.124 +50.190.99.163,59.71.57.127 +76.35.203.218,85.99.160.174 +10.105.193.147,65.239.245.8 +16.149.187.132,60.183.183.160 +41.254.172.253,91.29.212.120 +74.73.147.118,109.80.61.122 +17.4.216.218,81.28.221.132 +43.81.25.152,56.188.251.152 +77.129.46.26,111.84.135.164 +37.59.115.194,67.83.164.1 +15.68.3.129,16.49.6.124 +28.8.204.220,65.243.236.129 +75.225.49.114,96.241.203.151 +3.15.234.11,24.64.197.100 +34.94.213.204,86.251.104.189 +10.128.143.25,82.103.205.5 +71.40.137.28,111.102.207.10 +64.27.242.216,84.69.57.91 +15.243.70.143,56.238.197.220 +38.254.126.94,98.41.191.228 +52.243.205.85,87.8.102.223 +48.123.117.184,97.148.1.215 +20.47.88.82,50.184.239.172 +45.250.144.23,49.114.241.159 +60.177.182.85,116.70.243.154 +37.163.230.192,63.137.249.12 +60.113.25.165,67.9.244.125 +1.208.54.119,70.193.226.148 +40.84.112.80,97.200.58.54 +51.134.200.120,73.89.43.213 +18.73.146.27,35.58.199.66 +29.163.154.242,47.13.239.253 +70.33.203.17,81.247.234.185 +44.29.177.199,59.1.30.231 +43.108.190.69,88.118.33.171 +3.76.212.195,21.22.15.77 +1.86.157.118,23.114.183.156 +25.145.209.236,78.237.194.29 +7.21.59.206,49.10.67.191 +5.59.115.251,39.87.203.22 +26.113.206.227,78.246.33.89 +63.182.114.200,89.129.104.225 +57.16.46.101,97.136.239.169 +17.44.75.135,41.199.11.2 +73.68.68.203,103.109.0.168 +64.153.9.178,115.176.151.5 +48.79.148.172,84.194.181.33 +24.196.200.223,32.115.44.85 +42.169.78.19,102.124.25.58 +35.97.81.123,50.58.123.109 +3.28.33.199,69.158.66.13 +29.10.18.253,48.191.92.197 +56.17.33.139,87.82.71.234 +9.28.179.73,60.6.190.232 +40.60.2.130,84.210.192.53 +15.66.208.85,83.58.155.142 +76.127.130.244,82.183.70.10 +47.197.164.49,52.86.48.133 +76.146.90.0,90.250.190.93 +21.150.89.191,31.47.92.18 +7.52.193.236,11.72.189.53 +19.73.170.121,36.237.22.110 +29.74.41.57,89.102.255.64 +11.242.89.1,12.69.81.7 +28.43.120.214,86.142.45.84 +9.133.106.72,64.148.10.248 +28.26.193.176,89.121.174.180 +14.144.97.162,43.144.43.78 +60.241.49.245,96.29.140.117 +15.128.41.28,59.123.27.129 +3.229.56.154,29.168.205.37 +46.240.36.165,90.172.158.148 +0.75.73.222,68.59.26.115 +13.47.146.126,46.13.220.247 +71.157.116.209,115.70.185.135 +36.151.14.0,83.33.47.175 +54.240.95.180,95.249.127.183 +49.120.22.53,49.147.86.36 +27.31.201.55,56.195.88.163 +55.17.225.229,81.57.195.214 +46.160.8.183,103.201.130.37 +27.226.243.182,35.54.218.92 diff --git a/data/tests/iplookup/2.ips b/data/tests/iplookup/2.ips new file mode 100644 --- /dev/null +++ b/data/tests/iplookup/2.ips @@ -0,0 +1,5 @@ +68.66.248.20 +127.0.0.1 +40.18.226.141 +42.255.174.226 +192.168.1.1 diff --git a/data/tests/iplookup/2.out b/data/tests/iplookup/2.out new file mode 100644 --- /dev/null +++ b/data/tests/iplookup/2.out @@ -0,0 +1,5 @@ +68.66.248.20: YES +127.0.0.1: NO +40.18.226.141: YES +42.255.174.226: YES +192.168.1.1: NO diff --git a/data/tests/iplookup/2.out.golden b/data/tests/iplookup/2.out.golden new file mode 100644 --- /dev/null +++ b/data/tests/iplookup/2.out.golden @@ -0,0 +1,5 @@ +68.66.248.20: YES +127.0.0.1: NO +40.18.226.141: YES +42.255.174.226: YES +192.168.1.1: NO diff --git a/du/DiskUsage.hs b/du/DiskUsage.hs --- a/du/DiskUsage.hs +++ b/du/DiskUsage.hs @@ -3,7 +3,7 @@ module DiskUsage (diskUsage) where import Control.Monad.RWS -import System.FilePath (isExtensionOf) +import System.FilePath (takeExtension) import System.Posix.Types (FileOffset) import System.PosixCompat.Files (FileStatus, getFileStatus, isDirectory, isRegularFile, fileSize) @@ -32,7 +32,7 @@ -- addToTS :: FileOffset -> DUApp () addToTS ofs = modify (\st -> st {st_field = st_field st + ofs}) needRec _ Nothing _ = True - needRec fp (Just ext) isFile = isFile && ext `isExtensionOf` fp + needRec fp (Just ext) isFile = isFile && (ext == takeExtension fp) logDiffTS :: FileOffset -> DUApp () logDiffTS ts = do diff --git a/du/FileCount.hs b/du/FileCount.hs deleted file mode 100644 --- a/du/FileCount.hs +++ /dev/null @@ -1,24 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} - -module FileCount (fileCount) where - -import Control.Monad.RWS -import System.FilePath -import System.Directory -import System.PosixCompat.Files - -import TraverseDir -import App - -fileCount :: MyApp Int () -fileCount = do - AppState {..} <- get - fs <- liftIO $ getFileStatus curPath - when (isDirectory fs) $ do - AppConfig {..} <- ask - when (curDepth <= maxDepth) $ traverseDirectoryWith fileCount - files <- liftIO $ listDirectory curPath - tell [(curPath, length $ filterFiles ext files)] - where - filterFiles Nothing = id - filterFiles (Just ext) = filter (ext `isExtensionOf`) diff --git a/du/FileCounter.hs b/du/FileCounter.hs new file mode 100644 --- /dev/null +++ b/du/FileCounter.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE RecordWildCards #-} + +module FileCounter (fileCount) where + +import Control.Monad.RWS +import System.FilePath +import System.Directory +import System.PosixCompat.Files + +import TraverseDir +import App + +fileCount :: MyApp Int () +fileCount = do + AppState {..} <- get + fs <- liftIO $ getFileStatus curPath + when (isDirectory fs) $ do + AppConfig {..} <- ask + when (curDepth <= maxDepth) $ traverseDirectoryWith fileCount + files <- liftIO $ listDirectory curPath + tell [(curPath, length $ filterFiles ext files)] + where + filterFiles Nothing = id + filterFiles (Just ext) = filter ((ext==).takeExtension) diff --git a/du/du.hs b/du/du.hs --- a/du/du.hs +++ b/du/du.hs @@ -8,7 +8,7 @@ import App import DiskUsage -import FileCount +import FileCounter mkConfig :: Opt.Parser AppConfig mkConfig = AppConfig diff --git a/expr/EvalRPNExcept.hs b/expr/EvalRPNExcept.hs new file mode 100644 --- /dev/null +++ b/expr/EvalRPNExcept.hs @@ -0,0 +1,62 @@ +module EvalRPNExcept (evalRPN, EvalError) where + +import Control.Monad.State +import Control.Monad.Except +import Control.Monad.Reader +import Data.Foldable (traverse_) +import Data.Semigroup ((<>)) +import Safe + +{- + Function evalRPN evaluates an expression given + in the reversed polish notation (RPN, postfix notation): + + evalRPN "2 3 +" ==> 5 (== "2 + 3") + evalRPN "2 3 4 + *" ==> 14 (== 2 * (3 + 4)) +-} + +data EvalError = NotEnoughElements | NotANumber String | ExtraElements + +instance Show EvalError where + show NotEnoughElements = "Not enough elements in the expression" + show (NotANumber s) = "Expression component '" <> s <> "' is not a number" + show ExtraElements = "There are extra elements in the expression" + +type Stack = [Integer] + +type EvalM = ExceptT EvalError (State Stack) + +push :: Integer -> EvalM () +push x = modify (x:) + +pop :: EvalM Integer +pop = do + xs <- get + when (null xs) $ throwError NotEnoughElements + put (tail xs) + pure (head xs) + +oneElementOnStack :: EvalM () +oneElementOnStack = do + l <- gets length + when (l /= 1) $ throwError ExtraElements + +handleNaN :: String -> Maybe Integer -> EvalM Integer +handleNaN s Nothing = throwError (NotANumber s) +handleNaN _ (Just n) = pure n + +readSafe :: String -> EvalM Integer +readSafe s = handleNaN s (readMay s) + +evalRPN :: String -> Either EvalError Integer +evalRPN str = evalState (runExceptT evalRPN') [] + where + evalRPN' = traverse_ step (words str) >> oneElementOnStack >> pop + step "+" = processTops (+) + step "*" = processTops (*) + step t = readSafe t >>= push + processTops op = op <$> pop <*> pop >>= push + +displayResults :: Either EvalError Integer -> String +displayResults (Left e) = "Error: " <> show e +displayResults (Right n) = show n diff --git a/expr/EvalRPNExcept2.hs b/expr/EvalRPNExcept2.hs new file mode 100644 --- /dev/null +++ b/expr/EvalRPNExcept2.hs @@ -0,0 +1,76 @@ +module EvalRPNExcept2 (evalRPN, EvalError) where + +import Control.Monad.State +import Control.Monad.Except +import Control.Monad.Reader +import Data.List +import Control.Applicative +import Data.Foldable (traverse_) +import Data.Semigroup ((<>)) +import Safe + +{- + Function evalRPN evaluates an expression given + in the reversed polish notation (RPN, postfix notation): + + evalRPN "2 3 +" ==> 5 (== "2 + 3") + evalRPN "2 3 4 + *" ==> 14 (== 2 * (3 + 4)) +-} + +data EvalError = NotEnoughElements | NotANumber String | ExtraElements + +instance Show EvalError where + show NotEnoughElements = "Not enough elements in the expression" + show (NotANumber s) = "Expression component '" <> s <> "' is not a number" + show ExtraElements = "There are extra elements in the expression" + +type Stack = [Integer] + +type EnvVars = [(String, Integer)] + +type EvalM = ReaderT EnvVars (ExceptT EvalError (State Stack)) + +push :: Integer -> EvalM () +push x = modify (x:) + +pop :: EvalM Integer +pop = do + xs <- get + when (null xs) $ throwError NotEnoughElements + put (tail xs) + pure (head xs) + +oneElementOnStack :: EvalM () +oneElementOnStack = do + l <- gets length + when (l /= 1) $ throwError ExtraElements + +handleNaN :: String -> Maybe Integer -> EvalM Integer +handleNaN s Nothing = throwError (NotANumber s) +handleNaN _ (Just n) = pure n + +readSafe :: String -> EvalM Integer +readSafe s = handleNaN s (readMay s) + +readSafe' :: String -> EvalM Integer +readSafe' s = liftM2 (<|>) (pure $ readMay s) (asks $ lookup s) + >>= handleNaN s + +readSafe'' :: String -> EvalM Integer +readSafe'' s = readSafe s `catchError` handler + where + handler (NotANumber s) = asks (lookup s) >>= handleNaN s + handler e = throwError e + +evalRPN :: String -> EnvVars -> Either EvalError Integer +evalRPN str env = evalState (runExceptT (runReaderT evalRPN' env)) [] + where + evalRPN' = traverse_ step (words str) >> oneElementOnStack >> pop + step "+" = processTops (+) + step "*" = processTops (*) + step t = readSafe'' t >>= push + processTops op = op <$> pop <*> pop >>= push + +displayResults :: Either EvalError Integer -> String +displayResults (Left e) = "Error: " <> show e +displayResults (Right n) = show n diff --git a/expr/rpnexpr.hs b/expr/rpnexpr.hs --- a/expr/rpnexpr.hs +++ b/expr/rpnexpr.hs @@ -2,6 +2,10 @@ import qualified EvalRPN_trans as E1 import qualified EvalRPN_trans2 as E2 +import qualified EvalRPNExcept as EE +import qualified EvalRPNExcept2 as EE2 + + import Control.Monad (mapM_, when) import Data.Maybe diff --git a/expr/shunting-yard.hs b/expr/shunting-yard.hs --- a/expr/shunting-yard.hs +++ b/expr/shunting-yard.hs @@ -17,9 +17,9 @@ pop :: State MyState Token pop = do - (t : s, es) <- get -- let it crash on empty stack - put (s, es) - pure t + (s, es) <- get + put (tail s, es) -- let it crash on empty stack + pure (head s) pop_ :: State MyState () -- let it crash on empty stack pop_ = modify (\(s, es) -> (tail s, es)) diff --git a/hid-examples.cabal b/hid-examples.cabal --- a/hid-examples.cabal +++ b/hid-examples.cabal @@ -1,13 +1,13 @@ -cabal-version: >= 1.10 +cabal-version: 2.0 --- This file has been generated from package.yaml by hpack version 0.29.7. +-- This file has been generated from package.yaml by hpack version 0.31.1. -- -- see: https://github.com/sol/hpack -- --- hash: 4c5a4f5427bcb54285ad846ee88355b7c5c537a0cb7f6501f6a5bb3d656b2f7c +-- hash: ac5a8f195a31a03e887adbecdabc12899f40559e1a39a78701af7538f5ed14a8 name: hid-examples -version: 0.3 +version: 0.4 synopsis: Examples to accompany the book "Haskell in Depth" description: This package provides source code examples which accompany the book "Haskell in Depth" by Vitaly Bragilevsky (Manning Publications 2019). You may want to get this package via @cabal get hid-examples@ and explore its content. category: Sample Code @@ -17,17 +17,29 @@ maintainer: Vitaly Bragilevsky license: BSD3 license-file: LICENSE +tested-with: GHC == 8.2.2, GHC == 8.4.3 build-type: Simple extra-source-files: - .travis.yml - appveyor.yml ChangeLog.md LICENSE - package.yaml README.md stack.yaml + .travis.yml + appveyor.yml + package.yaml data-files: + data/ipranges.txt data/quotes.csv + data/ssrequests.txt + data/suntimes.config.sample.json + data/tests/iplookup/1.iprs + data/tests/iplookup/1.ips + data/tests/iplookup/1.out + data/tests/iplookup/1.out.golden + data/tests/iplookup/2.iprs + data/tests/iplookup/2.ips + data/tests/iplookup/2.out + data/tests/iplookup/2.out.golden texts/Dracula.srt texts/forsyte.txt texts/hamlet.txt @@ -38,12 +50,40 @@ type: git location: https://github.com/bravit/hid-examples +library ipgen-lib + exposed-modules: + GenIP + hs-source-dirs: + ipgen + build-depends: + base >=4.10 && <4.13 + , hedgehog >=0.5 && <0.7 + , iplookup-lib + default-language: Haskell2010 + +library iplookup-lib + exposed-modules: + IPTypes + LookupIP + ParseIP + hs-source-dirs: + iplookup + other-extensions: TypeApplications + build-depends: + base >=4.10 && <4.13 + , safe >=0.3 && <0.4 + , safe-exceptions >=0.1.5 && <0.2 + , split >=0.2 && <0.3 + default-language: Haskell2010 + executable dicegame main-is: dicegame.hs other-modules: Paths_hid_examples + autogen-modules: + Paths_hid_examples build-depends: - base >=4.10 && <4.12 + base >=4.10 && <4.13 , mtl >=2.0 && <2.3 , random >=1.0 && <1.2 default-language: Haskell2010 @@ -54,15 +94,18 @@ App AppRWS DiskUsage - FileCount + FileCounter TraverseDir Paths_hid_examples + autogen-modules: + Paths_hid_examples hs-source-dirs: du + other-extensions: GeneralizedNewtypeDeriving RecordWildCards FlexibleContexts build-depends: - base >=4.10 && <4.12 + base >=4.10 && <4.13 , directory >=1.3 && <1.4 - , filepath >=1.4.2 && <1.5 + , filepath >=1.4.1 && <1.5 , mtl >=2.0 && <2.3 , optparse-applicative >=0.14 && <0.15 , unix-compat >=0.5 && <0.6 @@ -72,8 +115,10 @@ main-is: filecount.hs other-modules: Paths_hid_examples + autogen-modules: + Paths_hid_examples build-depends: - base >=4.10 && <4.12 + base >=4.10 && <4.13 , extra >=1.5 && <1.7 default-language: Haskell2010 @@ -81,8 +126,10 @@ main-is: gcd.hs other-modules: Paths_hid_examples + autogen-modules: + Paths_hid_examples build-depends: - base >=4.10 && <4.12 + base >=4.10 && <4.13 , mtl >=2.0 && <2.3 default-language: Haskell2010 @@ -90,9 +137,11 @@ main-is: genSQL.hs other-modules: Paths_hid_examples + autogen-modules: + Paths_hid_examples other-extensions: OverloadedStrings ViewPatterns build-depends: - base >=4.10 && <4.12 + base >=4.10 && <4.13 , mtl >=2.0 && <2.3 , text >=1.2 && <1.3 default-language: Haskell2010 @@ -101,24 +150,57 @@ main-is: ioref.hs other-modules: Paths_hid_examples + autogen-modules: + Paths_hid_examples build-depends: - base >=4.10 && <4.12 + base >=4.10 && <4.13 default-language: Haskell2010 +executable ipgen + main-is: ipgen/Main.hs + other-modules: + Paths_hid_examples + autogen-modules: + Paths_hid_examples + build-depends: + base >=4.10 && <4.13 + , hedgehog >=0.5 && <0.7 + , ipgen-lib + , optparse-applicative >=0.14 && <0.15 + , safe-exceptions >=0.1.5 && <0.2 + default-language: Haskell2010 + +executable iplookup + main-is: iplookup/Main.hs + other-modules: + Paths_hid_examples + autogen-modules: + Paths_hid_examples + build-depends: + base >=4.10 && <4.13 + , iplookup-lib + , optparse-applicative >=0.14 && <0.15 + , safe-exceptions >=0.1.5 && <0.2 + default-language: Haskell2010 + executable locator main-is: locator.hs other-modules: Paths_hid_examples + autogen-modules: + Paths_hid_examples build-depends: - base >=4.10 && <4.12 + base >=4.10 && <4.13 default-language: Haskell2010 executable maybe main-is: maybe.hs other-modules: Paths_hid_examples + autogen-modules: + Paths_hid_examples build-depends: - base >=4.10 && <4.12 + base >=4.10 && <4.13 , safe >=0.3 && <0.4 default-language: Haskell2010 @@ -126,9 +208,11 @@ main-is: reader.hs other-modules: Paths_hid_examples + autogen-modules: + Paths_hid_examples other-extensions: NamedFieldPuns build-depends: - base >=4.10 && <4.12 + base >=4.10 && <4.13 , mtl >=2.0 && <2.3 default-language: Haskell2010 @@ -138,12 +222,17 @@ EvalRPN EvalRPN_trans EvalRPN_trans2 + EvalRPNExcept + EvalRPNExcept2 MyMaybeT Paths_hid_examples + autogen-modules: + Paths_hid_examples hs-source-dirs: expr + other-extensions: FlexibleInstances MultiParamTypeClasses UndecidableInstances InstanceSigs LambdaCase build-depends: - base >=4.10 && <4.12 + base >=4.10 && <4.13 , mtl >=2.0 && <2.3 , safe >=0.3 && <0.4 , transformers >=0.5 && <0.6 @@ -153,8 +242,10 @@ main-is: expr/showexpr.hs other-modules: Paths_hid_examples + autogen-modules: + Paths_hid_examples build-depends: - base >=4.10 && <4.12 + base >=4.10 && <4.13 , hint >=0.7 && <0.10 default-language: Haskell2010 @@ -162,8 +253,10 @@ main-is: expr/shunting-yard.hs other-modules: Paths_hid_examples + autogen-modules: + Paths_hid_examples build-depends: - base >=4.10 && <4.12 + base >=4.10 && <4.13 , mtl >=2.0 && <2.3 default-language: Haskell2010 @@ -178,13 +271,15 @@ Statistics StatReport Paths_hid_examples + autogen-modules: + Paths_hid_examples hs-source-dirs: stockquotes other-extensions: RecordWildCards OverloadedStrings FlexibleInstances DeriveGeneric DeriveAnyClass build-depends: Chart >=1.8 && <1.10 , Chart-diagrams >=1.8 && <1.10 - , base >=4.10 && <4.12 + , base >=4.10 && <4.13 , blaze-html >=0.9 && <0.10 , bytestring >=0.10 && <0.11 , cassava >=0.5 && <0.6 @@ -199,16 +294,52 @@ main-is: stref.hs other-modules: Paths_hid_examples + autogen-modules: + Paths_hid_examples build-depends: - base >=4.10 && <4.12 + base >=4.10 && <4.13 default-language: Haskell2010 +executable suntimes + main-is: Main.hs + other-modules: + App + GeoCoordsReq + ProcessRequest + STExcept + SunTimes + Types + Paths_hid_examples + autogen-modules: + Paths_hid_examples + hs-source-dirs: + suntimes + default-extensions: OverloadedStrings + other-extensions: RecordWildCards DeriveGeneric + build-depends: + aeson >=1.2 && <1.5 + , base >=4.10 && <4.13 + , bytestring >=0.10 && <0.11 + , data-default >=0.5 && <0.8 + , http-client >=0.4 && <0.6 + , mtl >=2.0 && <2.3 + , optparse-applicative >=0.14 && <0.15 + , req >=1.0 && <1.3 + , safe-exceptions >=0.1.5 && <0.2 + , system-locale >=0.2 && <0.4 + , text >=1.2 && <1.3 + , time >=1.8 && <1.10 + , transformers >=0.5 && <0.6 + default-language: Haskell2010 + executable vocab1 main-is: vocab1.hs other-modules: Paths_hid_examples + autogen-modules: + Paths_hid_examples build-depends: - base >=4.10 && <4.12 + base >=4.10 && <4.13 , text >=1.2 && <1.3 default-language: Haskell2010 @@ -216,8 +347,10 @@ main-is: vocab2.hs other-modules: Paths_hid_examples + autogen-modules: + Paths_hid_examples build-depends: - base >=4.10 && <4.12 + base >=4.10 && <4.13 , text >=1.2 && <1.3 default-language: Haskell2010 @@ -225,8 +358,10 @@ main-is: vocab3.hs other-modules: Paths_hid_examples + autogen-modules: + Paths_hid_examples build-depends: - base >=4.10 && <4.12 + base >=4.10 && <4.13 , text >=1.2 && <1.3 default-language: Haskell2010 @@ -234,8 +369,48 @@ main-is: weapons.hs other-modules: Paths_hid_examples + autogen-modules: + Paths_hid_examples build-depends: - base >=4.10 && <4.12 + base >=4.10 && <4.13 , mtl >=2.0 && <2.3 , random >=1.0 && <1.2 + default-language: Haskell2010 + +test-suite iplookup-doctest + type: exitcode-stdio-1.0 + main-is: tests/iplookup-doctest/Doctests.hs + other-modules: + Paths_hid_examples + autogen-modules: + Paths_hid_examples + ghc-options: -threaded + build-depends: + base >=4.10 && <4.13 + , doctest >=0.12 && <0.17 + default-language: Haskell2010 + +test-suite iplookup-test + type: exitcode-stdio-1.0 + main-is: Test.hs + other-modules: + GoldenTests + LookupIPSpec + ParseIPSpec + Props + Paths_hid_examples + autogen-modules: + Paths_hid_examples + hs-source-dirs: + tests/iplookup + build-depends: + base >=4.10 && <4.13 + , filepath >=1.4.1 && <1.5 + , hedgehog >=0.5 && <0.7 + , ipgen-lib + , iplookup-lib + , tasty >=0.11 && <1.3 + , tasty-golden >=2.3 && <2.4 + , tasty-hedgehog >=0.1 && <0.3 + , tasty-hspec >=1.1 && <1.2 default-language: Haskell2010 diff --git a/ipgen/GenIP.hs b/ipgen/GenIP.hs new file mode 100644 --- /dev/null +++ b/ipgen/GenIP.hs @@ -0,0 +1,41 @@ +module GenIP where + +import Hedgehog +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range +import Data.Word +import Data.List +import Control.Monad + +import IPTypes + +genIP :: Gen IP +genIP = IP <$> Gen.word32 Range.linearBounded + +genIPComponents :: Gen [Word8] +genIPComponents = Gen.list (Range.singleton 4) genOctet + where genOctet = Gen.word8 Range.linearBounded + +genIPString :: Gen String +genIPString = intercalate "." . map show <$> genIPComponents + +genIPRange :: Gen IPRange +genIPRange = do + (IP ip1) <- genIP + ip2 <- Gen.word32 (Range.linearFrom (ip1 + 1) ip1 maxBound) + pure $ IPRange (IP ip1) (IP ip2) + +genInvalidIPRange :: Gen IPRange +genInvalidIPRange = do + (IP ip1) <- Gen.filter (> IP minBound) genIP + ip2 <- Gen.word32 (Range.linear minBound (ip1 - 1)) + pure $ IPRange (IP ip1) (IP ip2) + +genIPRangeDBSized :: Int -> Int -> Gen IPRangeDB +genIPRangeDBSized minLen maxLen = IPRangeDB <$> Gen.list (Range.constant minLen maxLen) genIPRange + +genIPRangeDB :: Gen IPRangeDB +genIPRangeDB = do + n1 <- Gen.integral (Range.constant 1 100) + n2 <- Gen.integral (Range.constant n1 100) + genIPRangeDBSized n1 n2 diff --git a/ipgen/Main.hs b/ipgen/Main.hs new file mode 100644 --- /dev/null +++ b/ipgen/Main.hs @@ -0,0 +1,32 @@ +import Hedgehog +import qualified Hedgehog.Gen as Gen +import Options.Applicative as Opt +import Control.Exception.Safe +import System.Exit +import Data.Semigroup + +import GenIP + +data Params = Params + Int + FilePath + +mkParams :: Opt.Parser Params +mkParams = Params + <$> argument auto (metavar "SIZE" <> help "number of ranges") + <*> argument str (metavar "FILE" <> help "IP range database") + +writeFileWithRanges :: Params -> IO () +writeFileWithRanges (Params n fp) = do + str <- show <$> Gen.sample (genIPRangeDBSized n n) + writeFile fp str + +main = (execParser opts >>= writeFileWithRanges) + `catches` [Handler parserExit] + where + opts = + info (mkParams <**> helper) + (fullDesc <> + progDesc ("Generates IP range database")) + parserExit :: ExitCode -> IO () + parserExit _ = pure () diff --git a/iplookup/IPTypes.hs b/iplookup/IPTypes.hs new file mode 100644 --- /dev/null +++ b/iplookup/IPTypes.hs @@ -0,0 +1,42 @@ +module IPTypes where + +import Data.Word +import Data.List (intercalate) +import Control.Exception.Safe + +newtype IP = IP {unIP :: Word32} + deriving (Eq, Ord) + +instance Show IP where + show (IP ip) = intercalate "." $ map show [b4,b3,b2,b1] + where + (ip1, b1) = ip `divMod` 256 + (ip2, b2) = ip1 `divMod` 256 + (b4, b3) = ip2 `divMod` 256 + +data IPRange = IPRange IP IP + deriving Eq + +instance Show IPRange where + show (IPRange ip1 ip2) = show ip1 ++ "," ++ show ip2 + +data IPRangeDB = IPRangeDB [IPRange] + deriving Eq + +instance Show IPRangeDB where + show (IPRangeDB iprs) = unlines $ map show iprs + +type LineNumber = Int + +newtype ParseError = ParseError LineNumber + deriving (Show, Eq) + +data InvalidArgsException = LoadIPRangesError ParseError + | InvalidIP String + +instance Show InvalidArgsException where + show (LoadIPRangesError (ParseError idx)) = + "Error loading ip range databases (line: " ++ show idx ++ ")" + show (InvalidIP s) = "Invalid IP address to check: " ++ s + +instance Exception InvalidArgsException diff --git a/iplookup/LookupIP.hs b/iplookup/LookupIP.hs new file mode 100644 --- /dev/null +++ b/iplookup/LookupIP.hs @@ -0,0 +1,20 @@ +module LookupIP where + +import Data.List + +import IPTypes +import ParseIP + +lookupIP :: IPRangeDB -> IP -> Bool +lookupIP (IPRangeDB ips) ip = case find (inRange ip) ips of + Nothing -> False + Just _ -> True + where + inRange ip (IPRange beg end) = beg <= ip && ip <= end + +reportIPs :: IPRangeDB -> [IP] -> String +reportIPs iprdb = unlines . map go + where + go ip = show ip ++ ": " ++ yesno (lookupIP iprdb ip) + yesno True = "YES" + yesno False = "NO" diff --git a/iplookup/Main.hs b/iplookup/Main.hs new file mode 100644 --- /dev/null +++ b/iplookup/Main.hs @@ -0,0 +1,38 @@ +module Main where + +import Options.Applicative as Opt +import Control.Exception.Safe +import System.Exit +import Data.Semigroup + +import IPTypes +import ParseIP +import LookupIP + +data Params = Params + FilePath + String + +mkParams :: Opt.Parser Params +mkParams = Params + <$> argument str (metavar "FILE" <> help "IP range database") + <*> argument str (metavar "IP" <> help "IP address to check") + +run :: Params -> IO () +run (Params fp ipstr) = do + iprs <- parseIPRanges <$> readFile fp + case (iprs, parseIP ipstr) of + (_, Nothing) -> throw (InvalidIP ipstr) + (Left pe, _) -> throw (LoadIPRangesError pe) + (Right iprdb, Just ip) -> putStrLn $ reportIPs iprdb [ip] + +main = (execParser opts >>= run) + `catches` [Handler parserExit] + where + opts = + info (mkParams <**> helper) + (fullDesc <> + progDesc ("Answers YES/NO depending on whether " ++ + "an IP address belongs to the IP range database")) + parserExit :: ExitCode -> IO () + parserExit _ = pure () diff --git a/iplookup/ParseIP.hs b/iplookup/ParseIP.hs new file mode 100644 --- /dev/null +++ b/iplookup/ParseIP.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE TypeApplications #-} + +module ParseIP where + +import Data.Word +import Data.Bits (shiftL, toIntegralSized) +import Data.List.Split (splitOn) +import Data.Maybe (mapMaybe) +import Control.Applicative +import Control.Monad +import Safe + +import IPTypes + +buildIP :: [Word8] -> IP +buildIP = IP . fst . foldr go (0, 1) + where + go b (s, k) = (s + fromIntegral b * k, k*256) + +buildIP' :: [Word8] -> IP +buildIP' = IP . foldl (\s b -> s*256 + fromIntegral b) 0 + +buildIP'' :: [Word8] -> IP +buildIP'' = IP . foldl (\s b -> shiftL s 8 + fromIntegral b) 0 + +guarded :: Alternative f => (a -> Bool) -> a -> f a +guarded f a = if f a then pure a else empty + +-- | Checks if the list has the given length +-- +-- >>> 4 `isLengthOf` [1,2,3,4] +-- True +-- >>> 0 `isLengthOf` [] +-- True +-- >>> 0 `isLengthOf` [1,2,3,4] +-- False + +isLengthOf :: Int -> [a] -> Bool +isLengthOf n xs = length xs == n + +-- | Parses IP address given as a 'String' +-- +-- >>> parseIP "0.0.0.0" +-- Just 0.0.0.0 +-- +-- >>> parseIP "192.168.3.15" +-- Just 192.168.3.15 +-- +-- >>> parseIP "not an IP address" +-- Nothing + +parseIP :: String -> Maybe IP +parseIP = guarded (4 `isLengthOf`) . splitOn "." + >=> mapM (readMay @Integer >=> toIntegralSized) + >=> pure . buildIP + +parseIPRange :: String -> Maybe IPRange +parseIPRange = guarded (2 `isLengthOf`) . splitOn "," + >=> mapM parseIP + >=> listToIPRange + where + listToIPRange [a,b] + | a <= b = pure (IPRange a b) + listToIPRange _ = empty + +parseIPRanges :: String -> Either ParseError IPRangeDB +parseIPRanges = fmap IPRangeDB . mapM parseLine . zip [1..] . lines + where + parseLine (ln, s) = case parseIPRange s of + Nothing -> Left (ParseError ln) + Just ipr -> Right ipr + +parseValidIPs :: String -> [IP] +parseValidIPs = mapMaybe parseIP . lines + +parseValidIPRanges :: String -> IPRangeDB +parseValidIPRanges = IPRangeDB . mapMaybe parseIPRange . lines diff --git a/package.yaml b/package.yaml --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: hid-examples -version: 0.3 +version: 0.4 synopsis: Examples to accompany the book "Haskell in Depth" description: This package provides source code examples which accompany the book @@ -23,30 +23,42 @@ data-files: - data/*.* + - data/tests/iplookup/*.* - texts/*.* -dependencies: base >=4.10 && <4.12 +tested-with: GHC == 8.2.2, GHC == 8.4.3 +dependencies: base >=4.10 && <4.13 + +_paths_workaround: &paths_workaround + generated-other-modules: Paths_hid_examples + executables: # Chapter 2 locator: main: locator.hs + <<: *paths_workaround vocab1: main: vocab1.hs + <<: *paths_workaround dependencies: text >=1.2 && <1.3 vocab2: main: vocab2.hs + <<: *paths_workaround dependencies: text >=1.2 && <1.3 vocab3: main: vocab3.hs + <<: *paths_workaround dependencies: text >=1.2 && <1.3 showexpr: main: expr/showexpr.hs + <<: *paths_workaround dependencies: hint >=0.7 && <0.10 # Chapter 3 stockquotes: source-dirs: stockquotes main: Main.hs + <<: *paths_workaround other-extensions: - RecordWildCards - OverloadedStrings @@ -67,16 +79,19 @@ # Chapter 5 maybe: main: maybe.hs + <<: *paths_workaround dependencies: - safe >=0.3 && <0.4 reader: main: reader.hs + <<: *paths_workaround other-extensions: - NamedFieldPuns dependencies: - mtl >=2.0 && <2.3 genSQL: main: genSQL.hs + <<: *paths_workaround other-extensions: - OverloadedStrings - ViewPatterns @@ -85,44 +100,149 @@ - mtl >=2.0 && <2.3 gcd: main: gcd.hs + <<: *paths_workaround dependencies: - mtl >=2.0 && <2.3 weapons: main: weapons.hs + <<: *paths_workaround dependencies: - mtl >=2.0 && <2.3 - random >=1.0 && <1.2 shunting-yard: main: expr/shunting-yard.hs + <<: *paths_workaround dependencies: - mtl >=2.0 && <2.3 dicegame: main: dicegame.hs + <<: *paths_workaround dependencies: - mtl >=2.0 && <2.3 - random >=1.0 && <1.2 ioref: main: ioref.hs + <<: *paths_workaround filecount: main: filecount.hs + <<: *paths_workaround dependencies: - extra >=1.5 && <1.7 stref: main: stref.hs + <<: *paths_workaround # Chapter 6 du: source-dirs: du main: du.hs + <<: *paths_workaround dependencies: - mtl >=2.0 && <2.3 - - filepath >= 1.4.2 && < 1.5 + - filepath >= 1.4.1 && < 1.5 - directory >= 1.3 && < 1.4 - unix-compat >= 0.5 && < 0.6 - optparse-applicative >= 0.14 && < 0.15 + other-extensions: + - GeneralizedNewtypeDeriving + - RecordWildCards + - FlexibleContexts rpnexpr: source-dirs: expr main: rpnexpr.hs + <<: *paths_workaround dependencies: - mtl >= 2.0 && < 2.3 - transformers >= 0.5 && < 0.6 - safe >=0.3 && <0.4 + other-extensions: + - FlexibleInstances + - MultiParamTypeClasses + - UndecidableInstances + - InstanceSigs + - LambdaCase + # Chapter 7 + suntimes: + source-dirs: suntimes + main: Main.hs + <<: *paths_workaround + dependencies: + - mtl >= 2.0 && < 2.3 + - transformers >= 0.5 && < 0.6 + - time >=1.8 && <1.10 + - text >=1.2 && <1.3 + - safe-exceptions >= 0.1.5 && < 0.2 + - aeson >= 1.2 && < 1.5 + - req >= 1.0 && < 1.3 + - http-client >= 0.4 && < 0.6 + - data-default >= 0.5 && < 0.8 + - system-locale >= 0.2 && < 0.4 + - optparse-applicative >= 0.14 && < 0.15 + - bytestring >= 0.10 && < 0.11 + default-extensions: + - OverloadedStrings + other-extensions: + - RecordWildCards + - DeriveGeneric + # Chapter 8 + iplookup: + main: iplookup/Main.hs + <<: *paths_workaround + dependencies: + - safe-exceptions >= 0.1.5 && < 0.2 + - optparse-applicative >= 0.14 && < 0.15 + - iplookup-lib + ipgen: + main: ipgen/Main.hs + <<: *paths_workaround + dependencies: + - ipgen-lib + - safe-exceptions >= 0.1.5 && < 0.2 + - optparse-applicative >= 0.14 && < 0.15 + - hedgehog >= 0.5 && < 0.7 + +internal-libraries: + # Chapter 8 + iplookup-lib: + source-dirs: iplookup + exposed-modules: + - IPTypes + - LookupIP + - ParseIP + other-modules: [] + dependencies: + - safe >= 0.3 && < 0.4 + - split >= 0.2 && < 0.3 + - safe-exceptions >= 0.1.5 && < 0.2 + other-extensions: + - TypeApplications + ipgen-lib: + source-dirs: ipgen + exposed-modules: + - GenIP + other-modules: [] + dependencies: + - iplookup-lib + - hedgehog >= 0.5 && < 0.7 + +tests: + # Chapter 8 + iplookup-test: + main: Test.hs + <<: *paths_workaround + source-dirs: tests/iplookup + dependencies: + - iplookup-lib + - ipgen-lib + - tasty >= 0.11 && < 1.3 + - tasty-hspec >= 1.1 && < 1.2 + - tasty-hedgehog >= 0.1 && < 0.3 + - hedgehog >= 0.5 && < 0.7 + - tasty-golden >= 2.3 && < 2.4 + - filepath >= 1.4.1 && < 1.5 + iplookup-doctest: + main: tests/iplookup-doctest/Doctests.hs + <<: *paths_workaround + ghc-options: + - -threaded + dependencies: + - doctest >= 0.12 && < 0.17 diff --git a/stack.yaml b/stack.yaml --- a/stack.yaml +++ b/stack.yaml @@ -5,3 +5,4 @@ extra-deps: - filepath-1.4.2.1 +- system-locale-0.3.0.0 diff --git a/suntimes/App.hs b/suntimes/App.hs new file mode 100644 --- /dev/null +++ b/suntimes/App.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module App where + +import Control.Monad.Reader +import Control.Exception.Safe + +import Types + +newtype MyApp a = MyApp { + runApp :: ReaderT WebAPIAuth IO a + } deriving (Functor, Applicative, Monad, MonadIO, + MonadThrow, MonadCatch, MonadMask, + MonadReader WebAPIAuth) + +runMyApp :: MyApp a -> WebAPIAuth -> IO a +runMyApp app config = runReaderT (runApp app) config diff --git a/suntimes/GeoCoordsReq.hs b/suntimes/GeoCoordsReq.hs new file mode 100644 --- /dev/null +++ b/suntimes/GeoCoordsReq.hs @@ -0,0 +1,32 @@ +module GeoCoordsReq (getCoords) where + +import Network.HTTP.Req +import Data.Default +import Control.Exception.Safe +import qualified Data.Text as T +import Data.Text.Encoding (encodeUtf8) +import Control.Monad.Reader +import Control.Monad.IO.Class + +import App +import Types +import STExcept + +getCoords :: Address -> MyApp GeoCoords +getCoords addr = handle rethrowReqException $ do + wauth <- ask + let + ep = https "nominatim.openstreetmap.org" /: "search" + reqParams = + mconcat [ + "q" =: addr + , "format" =: ("json" :: T.Text) + , "limit" =: (1 :: Int) + , "email" =: email wauth + , header "User-Agent" (encodeUtf8 $ agent wauth) + ] + request = req GET ep NoReqBody jsonResponse reqParams + res <- liftIO $ responseBody <$> runReq def request + case res of + [] -> throw (UnknownLocation addr) + (coords:_) -> pure coords diff --git a/suntimes/Main.hs b/suntimes/Main.hs new file mode 100644 --- /dev/null +++ b/suntimes/Main.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +import Options.Applicative as Opt +import Data.Aeson +import Control.Exception.Safe +import qualified Data.Text as T +import qualified Data.Text.IO as TIO +import Control.Monad +import Control.Monad.IO.Class +import Data.Semigroup ((<>)) -- required for GHC 8.2 +import qualified Data.ByteString as B +import System.Exit +import System.IO.Error (isDoesNotExistError, ioeGetFileName) + +import App +import ProcessRequest +import STExcept + +data AppMode = FileInput FilePath | Interactive +data Params = Params + AppMode -- mode + FilePath -- config file + +mkParams :: Opt.Parser Params +mkParams = Params <$> (fileInput <|> interactive) <*> config + where + fileInput = FileInput <$> strOption + (long "file" <> short 'f' <> + metavar "FILENAME" <> help "Input file" ) + interactive = flag Interactive Interactive + (long "interactive" <> short 'i' <> + help "Interactive mode") + config = strOption (long "conf" <> short 'c' <> + value "config.json" <> + showDefault <> + metavar "CONFIGNAME" <> help "Configuration file" ) + +withConfig :: Params -> IO () +withConfig (Params appMode config) = do + wauth <- eitherDecodeStrict <$> B.readFile config + case wauth of + Right wauth' -> runMyApp (run appMode) wauth' + Left _ -> throwString $ "Error parsing configuration file" + where + run (FileInput fname) = liftIO (TIO.readFile fname) >>= processMany . T.lines + run Interactive = processInteractively + +main = (execParser opts >>= withConfig) + `catches` [Handler parserExit, + Handler printIOError, + Handler decodeConfigError, + Handler printOtherErrors] + where + opts = + info (mkParams <**> helper) + (fullDesc <> + progDesc "Reports sunrise/sunset times for the specified location") + parserExit :: ExitCode -> IO () + parserExit _ = pure () + printIOError :: IOException -> IO () + printIOError e + | isDoesNotExistError e = do + let mbfn = ioeGetFileName e + putStrLn $ "File " ++ maybe "" id mbfn ++ " not found" + | otherwise = putStrLn $ "I/O error: " ++ show e + decodeConfigError :: StringException -> IO () + decodeConfigError (StringException s _) = putStrLn s + printOtherErrors :: SomeException -> IO () + printOtherErrors = print diff --git a/suntimes/ProcessRequest.hs b/suntimes/ProcessRequest.hs new file mode 100644 --- /dev/null +++ b/suntimes/ProcessRequest.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE RecordWildCards, FlexibleContexts #-} + +module ProcessRequest (processMany, processInteractively) where + +import System.Locale.Read (TimeLocale, getCurrentLocale) +import Control.Exception.Safe +import qualified Data.Text as T +import qualified Data.Text.IO as TIO +import Data.Time +import Control.Monad +import Control.Monad.Reader +import Control.Monad.IO.Class + +import Control.Concurrent +import Data.Semigroup ((<>)) -- required for GHC 8.2 + +import App +import Types +import GeoCoordsReq +import SunTimes +import STExcept + +parseRequestLine :: T.Text -> Either RequestError (T.Text, When) +parseRequestLine t = parse (split t) + where + split t = case T.breakOn "@" t of + (addr, "") -> ("", addr) + (day, addr) -> (T.strip day, T.strip $ T.tail addr) + parse (_, "") = Left EmptyRequest + parse ("", addr) = Right (addr, Now) + parse (d, addr) = + case parseTimeM False defaultTimeLocale "%Y-%m-%d" (T.unpack d) of + Nothing -> Left (WrongDay d) + Just d' -> Right (addr, On d') + +formatResult :: T.Text -> SunTimes ZonedTime -> TimeLocale -> T.Text +formatResult req SunTimes {..} loc = mconcat [day, " @ ", req, + "\n ", fmt sunrise, + "\n ", fmt sunset] + where + day = T.pack $ formatTime loc "%x" sunrise + fmt t = T.pack $ formatTime loc "%X %Z" t + +processRequest :: T.Text -> MyApp T.Text +processRequest t = processR (parseRequestLine (T.strip t)) + where + processR (Left e) = throw (FormatError e) + processR (Right (addr, day)) = do + coords <- getCoords addr + st <- getSunTimes coords day + loc <- liftIO getCurrentLocale + `catchAny` (const $ pure defaultTimeLocale) + pure $ formatResult addr st loc + +processMany :: [T.Text] -> MyApp () +processMany = mapM_ processRequestWrapper + where + processRequestWrapper r = + unless ("#" `T.isPrefixOf` r) + $ (processRequest r >>= liftIO .TIO.putStrLn) `catch` handler r + `finally` delaySec 3 + delaySec sec = liftIO $ threadDelay (sec * 1000000) + handler :: T.Text -> SunInfoException -> MyApp () + handler r e = liftIO $ TIO.putStrLn $ "Error in request '" <> r <> "': " + <> T.pack (show e) + +processInteractively :: MyApp () +processInteractively = action `catch` handler + where + action = do + liftIO $ TIO.putStrLn "Enter your request:" + req <- liftIO $ TIO.getLine + res <- processRequest req + liftIO $ TIO.putStrLn res + + handler :: SunInfoException -> MyApp () + handler e@(ServiceAPIError _) = liftIO $ print e + handler e@(NetworkError _) = liftIO $ print e + handler e = do + liftIO $ TIO.putStr + $ "There was an error while processing your request: " + <> T.pack (show e) <> "\nDo you want to try again (Y/N)?" + yesno <- liftIO $ TIO.getLine + when (yesno `elem` ["y", "Y", "yes"]) processInteractively diff --git a/suntimes/STExcept.hs b/suntimes/STExcept.hs new file mode 100644 --- /dev/null +++ b/suntimes/STExcept.hs @@ -0,0 +1,35 @@ +module STExcept where + +import qualified Data.Text as T +import Control.Exception.Safe +import Network.HTTP.Req +import qualified Network.HTTP.Client as NC + +import Types + +data RequestError = EmptyRequest | WrongDay T.Text + deriving Show + +data SunInfoException = UnknownLocation T.Text + | UnknownTime GeoCoords + | FormatError RequestError + | ServiceAPIError String + | NetworkError SomeException + +instance Show SunInfoException where + show (UnknownLocation loc) = "Failed while determining coordinates" + show (UnknownTime loc) = "Failed while determining sunrise/sunset times" + show (FormatError er) = show er + show (ServiceAPIError _) = "Error while communicating with external services" + show (NetworkError _) = "Network communication error" + + +instance Exception SunInfoException + +rethrowReqException :: MonadThrow m => HttpException -> m a +rethrowReqException (JsonHttpException s) = throw (ServiceAPIError s) +rethrowReqException (VanillaHttpException ( + NC.HttpExceptionRequest _ + (NC.StatusCodeException resp _ ))) = + throw (ServiceAPIError $ show $ NC.responseStatus resp) +rethrowReqException (VanillaHttpException e) = throw (NetworkError $ toException e) diff --git a/suntimes/SunTimes.hs b/suntimes/SunTimes.hs new file mode 100644 --- /dev/null +++ b/suntimes/SunTimes.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE RecordWildCards, DeriveGeneric #-} + +module SunTimes (getSunTimes) where + +import Data.Aeson +import Network.HTTP.Req +import Data.Default +import Control.Exception.Safe +import Control.Monad.Reader +import Control.Monad.IO.Class +import qualified Data.Text as T +import Data.Time +import GHC.Generics + +import Types +import STExcept +import App + +newtype SunTimesWrapper dt = SunTimesWrapper {results :: SunTimes dt} + deriving (Show, Generic) + +instance FromJSON dt => FromJSON (SunTimesWrapper dt) + +getSunTimesUTC :: GeoCoords -> When -> MyApp (SunTimes UTCTime) +getSunTimesUTC GeoCoords {..} w = handle rethrowReqException $ liftIO $ runReq def $ do + r <- req GET ep NoReqBody jsonResponse reqParams + pure (results $ responseBody r) + where + ep = https "api.sunrise-sunset.org" /: "json" + reqParams = + mconcat $ [ "lat" =: lat + , "lng" =: lon + , "formatted" =: (0 :: Int) + ] ++ whenToOptions w + whenToOptions Now = [] + whenToOptions (On day) = ["date" =: formatTime defaultTimeLocale "%Y-%m-%d" day] + +getSunTimes :: GeoCoords -> When -> MyApp (SunTimes ZonedTime) +getSunTimes gc@GeoCoords {..} d = do + SunTimes {..} <- getSunTimesUTC gc d `catch` noTimeHandler + ltz <- lookupTimeZone gc sunrise `catchAny` (const $ pure utc) + return $ SunTimes (utcToZonedTime ltz sunrise) + (utcToZonedTime ltz sunset) + where + noTimeHandler :: MonadThrow m => SunInfoException -> m a + noTimeHandler (ServiceAPIError _) = throw (UnknownTime gc) + noTimeHandler e = throw e + +data TimeZoneInfo = TimeZoneInfo { gmtOffset :: Int + , abbreviation :: String + , dst :: String + } + deriving (Show, Generic) + +instance FromJSON TimeZoneInfo + +lookupTimeZone :: GeoCoords -> UTCTime -> MyApp TimeZone +lookupTimeZone gc@GeoCoords {..} t = do + key <- asks timeZoneDBkey + let + ep = http "api.timezonedb.com" /: "v2.1" /: "get-time-zone" + reqParams = mconcat [ "key" =: key + , "lat" =: lat + , "lng" =: lon + , "time" =: formatTime defaultTimeLocale "%s" t + , "format" =: ("json" :: T.Text) + , "fields" =: ("gmtOffset,abbreviation,dst" :: T.Text) + , "by" =: ("position" :: T.Text) + ] + r <- liftIO $ runReq def $ req GET ep NoReqBody jsonResponse reqParams + pure (timeZoneInfo2TimeZone $ responseBody r) + where + secondsToTimeZone s = minutesToTimeZone (s `div` 60) + timeZoneInfo2TimeZone TimeZoneInfo {..} = + (secondsToTimeZone gmtOffset) { timeZoneName = abbreviation + , timeZoneSummerOnly = dst == "1"} diff --git a/suntimes/Types.hs b/suntimes/Types.hs new file mode 100644 --- /dev/null +++ b/suntimes/Types.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Types where + +import Data.Text +import GHC.Generics +import Data.Time (Day) +import Data.Aeson +import Control.Exception.Safe + + +type Address = Text + +data When = Now | On Day + deriving Show + +data GeoCoords = GeoCoords { lat :: Text, + lon :: Text } + deriving (Show, Generic) + +instance FromJSON GeoCoords + +data SunTimes dt = SunTimes { sunrise :: dt, + sunset :: dt } + deriving (Show, Generic) + +instance FromJSON dt => FromJSON (SunTimes dt) + +data WebAPIAuth = WebAPIAuth { timeZoneDBkey :: Text, + email :: Text, + agent :: Text} + deriving (Generic, Show) + +instance FromJSON WebAPIAuth diff --git a/tests/iplookup-doctest/Doctests.hs b/tests/iplookup-doctest/Doctests.hs new file mode 100644 --- /dev/null +++ b/tests/iplookup-doctest/Doctests.hs @@ -0,0 +1,3 @@ +import Test.DocTest + +main = doctest ["-iiplookup", "iplookup/ParseIP.hs"] diff --git a/tests/iplookup/GoldenTests.hs b/tests/iplookup/GoldenTests.hs new file mode 100644 --- /dev/null +++ b/tests/iplookup/GoldenTests.hs @@ -0,0 +1,32 @@ +module GoldenTests (goldenTests) where + +import Test.Tasty +import Test.Tasty.Golden +import System.FilePath (normalise, takeBaseName, replaceExtension) + +import ParseIP +import LookupIP + +goldenTests :: IO [TestTree] +goldenTests = sequence [golden_lookupIP] + +testsDir = normalise "data/tests/iplookup/" + +golden_lookupIP :: IO TestTree +golden_lookupIP = testGroup "lookupIP" . map createTest + <$> findByExtension [".iprs"] testsDir + +createTest :: String -> TestTree +createTest iprsf = goldenVsFile + (takeBaseName iprsf) + goldenf + outf + testAction + where + ipsf = replaceExtension iprsf ".ips" + goldenf = replaceExtension iprsf ".out.golden" + outf = replaceExtension iprsf ".out" + testAction = do + iprs <- parseValidIPRanges <$> readFile iprsf + ips <- parseValidIPs <$> readFile ipsf + writeBinaryFile outf $ reportIPs iprs ips diff --git a/tests/iplookup/LookupIPSpec.hs b/tests/iplookup/LookupIPSpec.hs new file mode 100644 --- /dev/null +++ b/tests/iplookup/LookupIPSpec.hs @@ -0,0 +1,25 @@ +module LookupIPSpec where + +import Test.Tasty.Hspec +import Data.Word + +import IPTypes +import LookupIP + +lookupIPSpecs :: Spec +lookupIPSpecs = describe "LookupIP" $ do + spec_lookupIP + +spec_lookupIP :: Spec +spec_lookupIP = + describe "lookupIP" $ do + let empty_iprdb = IPRangeDB [] + sample_iprdb = IPRangeDB [IPRange (IP 0) (IP 1), IPRange (IP 100) (IP 120)] + ip1 = IP 110 + ip2 = IP 50 + it "no IP in empty list" $ + ip1 `shouldNotSatisfy` lookupIP empty_iprdb + it "IP in sample list" $ + ip1 `shouldSatisfy` lookupIP sample_iprdb + it "no IP in sample list" $ + ip2 `shouldNotSatisfy` lookupIP sample_iprdb diff --git a/tests/iplookup/ParseIPSpec.hs b/tests/iplookup/ParseIPSpec.hs new file mode 100644 --- /dev/null +++ b/tests/iplookup/ParseIPSpec.hs @@ -0,0 +1,85 @@ +module ParseIPSpec where + +import Data.Maybe +import Data.Word +import Test.Tasty.Hspec + +import IPTypes +import ParseIP + +parseIPSpecs :: Spec +parseIPSpecs = describe "ParseIP" $ do + spec_buildIP + spec_parseIP + spec_parseIPRange + spec_parseIPRanges + +spec_buildIP :: Spec +spec_buildIP = + describe "buildIP" $ do + it "builds from zero" $ + buildIP [0,0,0,0] `shouldBe` (IP 0) + it "builds from one" $ + buildIP [0,0,0,1] `shouldBe` (IP 1) + it "builds from localhost" $ + buildIP [127,0,0,1] `shouldBe` (IP $ 1 + 127 * 256^3) + it "builds from arbitrary address" $ + buildIP [192,168,3,15] `shouldBe` + (IP $ 15 + 3 * 256 + 168 * 256^2 + 192 * 256^3) + +spec_parseIP :: Spec +spec_parseIP = + describe "parseIP" $ do + it "parses zero" $ + parseIP "0.0.0.0" `shouldBe` Just (IP 0) + it "parses one" $ + parseIP "0.0.0.1" `shouldBe` Just (IP 1) + it "parses the largest IP address" $ + parseIP "255.255.255.255" `shouldBe` Just (IP maxBound) + it "parses some random IP address" $ + parseIP "192.168.3.15" `shouldBe` + Just (buildIP [192,168,3,15]) + it "fails to parse 3 components" $ + parseIP "192.168.1" `shouldBe` Nothing + it "fails to parse 4 components with suffix" $ + parseIP "192.168.1.1x" `shouldBe` Nothing + it "fails to parse empty component" $ + parseIP "192.168..1" `shouldBe` Nothing + it "fails to parse 5 components" $ + parseIP "192.168.1.0.1" `shouldBe` Nothing + it "fails to parse large components" $ + parseIP "256.168.1.0" `shouldBe` Nothing + it "fails to parse extremely large components" $ + parseIP "0.0.0.4294967338" `shouldBe` Nothing + it "fails to parse negative components" $ + parseIP "256.168.-1.0" `shouldBe` Nothing + it "fails to parse non-numeric components" $ + parseIP "192.x.1.0" `shouldBe` Nothing + +spec_parseIPRange :: Spec +spec_parseIPRange = + describe "parseIPRange" $ do + it "parses pair" $ + parseIPRange "192.168.0.1,192.168.3.100" `shouldBe` + IPRange <$> parseIP "192.168.0.1" <*> parseIP "192.168.3.100" + it "fails to parse single ip" $ + parseIPRange "192.168.0.1" `shouldBe` Nothing + it "fails to parse single ip with comma" $ + parseIPRange "192.168.0.1," `shouldBe` Nothing + it "fails to parse triple" $ + parseIPRange "192.168.0.1,192.168.0.2,192.168.0.4" `shouldBe` Nothing + +spec_parseIPRanges :: Spec +spec_parseIPRanges = + describe "parseIPRanges" $ do + let sample_range = "192.168.0.1,192.168.3.100" + sample_range2 = "0.0.0.0,0.0.0.1" + it "parses empty list" $ + parseIPRanges "" `shouldBe` Right (IPRangeDB []) + it "parses single range" $ + parseIPRanges sample_range `shouldBe` + Right (IPRangeDB $ catMaybes [parseIPRange sample_range]) + it "parses two ranges" $ + parseIPRanges (sample_range ++ "\n" ++ sample_range2) `shouldBe` + Right (IPRangeDB $ catMaybes [parseIPRange sample_range, + parseIPRange sample_range2]) diff --git a/tests/iplookup/Props.hs b/tests/iplookup/Props.hs new file mode 100644 --- /dev/null +++ b/tests/iplookup/Props.hs @@ -0,0 +1,70 @@ +module Props where + +import Hedgehog +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range + +import Test.Tasty +import Test.Tasty.Hedgehog + +import IPTypes +import GenIP +import ParseIP +import LookupIP + +prop_buildIPs :: Property +prop_buildIPs = property $ do + ipcs <- forAll genIPComponents + let ip = buildIP ipcs + buildIP' ipcs === ip + buildIP'' ipcs === ip + +prop_parseIP :: Property +prop_parseIP = property $ do + ip <- forAll genIP + parseIP (show ip) === Just ip + +prop_parseIP_show :: Property +prop_parseIP_show = property $ do + ip <- forAll genIP + tripping ip show parseIP + +prop_parseIPRange_show :: Property +prop_parseIPRange_show = property $ do + ipr <- forAll genIPRange + tripping ipr show parseIPRange + +prop_parseIPRanges_show :: Property +prop_parseIPRanges_show = property $ do + iprdb <- forAll genIPRangeDB + tripping iprdb show parseIPRanges +-- iprdb' <- evalEither (parseIPRanges $ show iprdb) +-- iprdb' === iprdb + +prop_no_parseInvalidIPRange :: Property +prop_no_parseInvalidIPRange = property $ do + inv_ip <- forAll genInvalidIPRange + parseIPRange (show inv_ip) === Nothing + +prop_lookupIP_empty :: Property +prop_lookupIP_empty = property $ do + ip <- forAll genIP + assert (not $ lookupIP (IPRangeDB []) ip) + +prop_lookupIP_bordersIncluded :: Property +prop_lookupIP_bordersIncluded = property $ do + iprdb@(IPRangeDB iprdbs) <- forAll genIPRangeDB + IPRange ip1 ip2 <- forAll $ Gen.element iprdbs + assert (lookupIP iprdb ip1) + assert (lookupIP iprdb ip2) + +props = [ + testProperty "buildIP agrees with buildIP' and buildIP''" prop_buildIPs + , testProperty "parseIP works as expected" prop_parseIP + , testProperty "parseIP agrees with show" prop_parseIP_show + , testProperty "parseIPRange agrees with show" prop_parseIPRange_show + , testProperty "parseIPRanges agrees with show" prop_parseIPRanges_show + , testProperty "no parse of invalid IP ranges" prop_no_parseInvalidIPRange + , testProperty "no ip in empty list" prop_lookupIP_empty + , testProperty "lookupIP includes borders" prop_lookupIP_bordersIncluded + ] diff --git a/tests/iplookup/Test.hs b/tests/iplookup/Test.hs new file mode 100644 --- /dev/null +++ b/tests/iplookup/Test.hs @@ -0,0 +1,19 @@ +import Test.Tasty +import Test.Tasty.Hspec + +import ParseIPSpec +import LookupIPSpec +import Props +import GoldenTests + +main = do + specs <- concat <$> mapM testSpecs + [ parseIPSpecs + , lookupIPSpecs + ] + goldens <- goldenTests + defaultMain (testGroup "All Tests" [ + testGroup "Specs" specs + , testGroup "Properties" props + , testGroup "Golden Tests" goldens + ])