hid-examples 0.3 → 0.4
raw patch · 44 files changed
+1526/−104 lines, 44 filesdep +aesondep +data-defaultdep +doctestdep ~basedep ~filepathnew-component:exe:ipgennew-component:exe:iplookupnew-component:exe:suntimes
Dependencies added: aeson, data-default, doctest, hedgehog, hid-examples, http-client, req, safe-exceptions, split, system-locale, tasty, tasty-golden, tasty-hedgehog, tasty-hspec
Dependency ranges changed: base, filepath
Files
- .travis.yml +23/−42
- ChangeLog.md +4/−0
- README.md +22/−2
- data/ipranges.txt +5/−0
- data/ssrequests.txt +6/−0
- data/suntimes.config.sample.json +5/−0
- data/tests/iplookup/1.iprs +8/−0
- data/tests/iplookup/1.ips +3/−0
- data/tests/iplookup/1.out +3/−0
- data/tests/iplookup/1.out.golden +3/−0
- data/tests/iplookup/2.iprs +100/−0
- data/tests/iplookup/2.ips +5/−0
- data/tests/iplookup/2.out +5/−0
- data/tests/iplookup/2.out.golden +5/−0
- du/DiskUsage.hs +2/−2
- du/FileCount.hs +0/−24
- du/FileCounter.hs +24/−0
- du/du.hs +1/−1
- expr/EvalRPNExcept.hs +62/−0
- expr/EvalRPNExcept2.hs +76/−0
- expr/rpnexpr.hs +4/−0
- expr/shunting-yard.hs +3/−3
- hid-examples.cabal +202/−27
- ipgen/GenIP.hs +41/−0
- ipgen/Main.hs +32/−0
- iplookup/IPTypes.hs +42/−0
- iplookup/LookupIP.hs +20/−0
- iplookup/Main.hs +38/−0
- iplookup/ParseIP.hs +77/−0
- package.yaml +123/−3
- stack.yaml +1/−0
- suntimes/App.hs +17/−0
- suntimes/GeoCoordsReq.hs +32/−0
- suntimes/Main.hs +69/−0
- suntimes/ProcessRequest.hs +84/−0
- suntimes/STExcept.hs +35/−0
- suntimes/SunTimes.hs +76/−0
- suntimes/Types.hs +34/−0
- tests/iplookup-doctest/Doctests.hs +3/−0
- tests/iplookup/GoldenTests.hs +32/−0
- tests/iplookup/LookupIPSpec.hs +25/−0
- tests/iplookup/ParseIPSpec.hs +85/−0
- tests/iplookup/Props.hs +70/−0
- tests/iplookup/Test.hs +19/−0
.travis.yml view
@@ -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
ChangeLog.md view
@@ -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.
README.md view
@@ -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 ```
+ data/ipranges.txt view
@@ -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
+ data/ssrequests.txt view
@@ -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
+ data/suntimes.config.sample.json view
@@ -0,0 +1,5 @@+{ + "email": "some@email",+ "agent": "SunTimes (Haskell in Depth/sample code from the book)",+ "timeZoneDBkey": "some key" +}
+ data/tests/iplookup/1.iprs view
@@ -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
+ data/tests/iplookup/1.ips view
@@ -0,0 +1,3 @@+68.66.248.20+127.0.0.1+40.18.226.141
+ data/tests/iplookup/1.out view
@@ -0,0 +1,3 @@+68.66.248.20: YES+127.0.0.1: NO+40.18.226.141: YES
+ data/tests/iplookup/1.out.golden view
@@ -0,0 +1,3 @@+68.66.248.20: YES+127.0.0.1: NO+40.18.226.141: YES
+ data/tests/iplookup/2.iprs view
@@ -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
+ data/tests/iplookup/2.ips view
@@ -0,0 +1,5 @@+68.66.248.20+127.0.0.1+40.18.226.141+42.255.174.226+192.168.1.1
+ data/tests/iplookup/2.out view
@@ -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
+ data/tests/iplookup/2.out.golden view
@@ -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
du/DiskUsage.hs view
@@ -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
− du/FileCount.hs
@@ -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`)
+ du/FileCounter.hs view
@@ -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)
du/du.hs view
@@ -8,7 +8,7 @@ import App import DiskUsage-import FileCount+import FileCounter mkConfig :: Opt.Parser AppConfig mkConfig = AppConfig
+ expr/EvalRPNExcept.hs view
@@ -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
+ expr/EvalRPNExcept2.hs view
@@ -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
expr/rpnexpr.hs view
@@ -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
expr/shunting-yard.hs view
@@ -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))
hid-examples.cabal view
@@ -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 <vit.bragilevsky@gmail.com> 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
+ ipgen/GenIP.hs view
@@ -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
+ ipgen/Main.hs view
@@ -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 ()
+ iplookup/IPTypes.hs view
@@ -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
+ iplookup/LookupIP.hs view
@@ -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"
+ iplookup/Main.hs view
@@ -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 ()
+ iplookup/ParseIP.hs view
@@ -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
package.yaml view
@@ -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
stack.yaml view
@@ -5,3 +5,4 @@ extra-deps: - filepath-1.4.2.1+- system-locale-0.3.0.0
+ suntimes/App.hs view
@@ -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
+ suntimes/GeoCoordsReq.hs view
@@ -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
+ suntimes/Main.hs view
@@ -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
+ suntimes/ProcessRequest.hs view
@@ -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
+ suntimes/STExcept.hs view
@@ -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)
+ suntimes/SunTimes.hs view
@@ -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"}
+ suntimes/Types.hs view
@@ -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
+ tests/iplookup-doctest/Doctests.hs view
@@ -0,0 +1,3 @@+import Test.DocTest++main = doctest ["-iiplookup", "iplookup/ParseIP.hs"]
+ tests/iplookup/GoldenTests.hs view
@@ -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
+ tests/iplookup/LookupIPSpec.hs view
@@ -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
+ tests/iplookup/ParseIPSpec.hs view
@@ -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])
+ tests/iplookup/Props.hs view
@@ -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+ ]
+ tests/iplookup/Test.hs view
@@ -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+ ])