Updates to build with stack and upstream changes

I figured this would be harder considering I haven't touched it in far
too long. Didn't take much work at all to get it built and running
again, and all tests (such as they are) pass.

+ stack didn't like the exe and test exe both using Main.hs
+ filled out other-modules in .cabal at stack's suggestion
+ EitherT is now ExceptT
+ pipes-concurrency deprecated `Unbounded` in favor of `unbounded`
+ tasty's wrapper of HSpec is now in IO
+ misc minor hLint changes
master
Levi Pearson 2016-01-31 20:14:35 -07:00
parent f8b361dc5b
commit a4e724ebff
8 changed files with 80 additions and 27 deletions

1
.gitignore vendored
View File

@ -1,3 +1,4 @@
cabal.sandbox.config cabal.sandbox.config
.cabal-sandbox/ .cabal-sandbox/
.stack-work/
dist/ dist/

View File

@ -17,9 +17,18 @@ cabal-version: >=1.10
executable pipes-irc-server executable pipes-irc-server
main-is: Main.hs main-is: Main.hs
other-modules: Pipes.IRC.Message.Parse other-modules: Pipes.IRC.Message
, Pipes.IRC.Message.Parse
, Pipes.IRC.Message.Render , Pipes.IRC.Message.Render
, Pipes.IRC.Message.Types , Pipes.IRC.Message.Types
, Pipes.IRC.Server
, Pipes.IRC.Server.Channel
, Pipes.IRC.Server.EventHandler
, Pipes.IRC.Server.IrcMonad
, Pipes.IRC.Server.Log
, Pipes.IRC.Server.Server
, Pipes.IRC.Server.User
, Pipes.IRC.Server.Util
, Pipes.IRC.Server.Types , Pipes.IRC.Server.Types
, Pipes.IRC.Server.MessageHandler , Pipes.IRC.Server.MessageHandler
-- other-extensions: -- other-extensions:
@ -49,7 +58,17 @@ executable pipes-irc-server
test-suite tests test-suite tests
type: exitcode-stdio-1.0 type: exitcode-stdio-1.0
main-is: Main.hs other-modules: Pipes.IRC.Message
, Pipes.IRC.Message.Parse
, Pipes.IRC.Message.Render
, Pipes.IRC.Message.Types
, Pipes.IRC.Server.Channel
, Pipes.IRC.Server.Server
, Pipes.IRC.Server.Types
, Pipes.IRC.Server.User
, Pipes.IRC.Server.Util
, ParseTests
main-is: Test.hs
build-depends: base build-depends: base
, mtl , mtl
, containers , containers

View File

@ -174,7 +174,7 @@ listenHandler srv (lsock, _) =
(hName, _) <- getNameInfo [] True False caddr (hName, _) <- getNameInfo [] True False caddr
(writeEnd, readEnd) <- spawn Unbounded (writeEnd, readEnd) <- spawn unbounded
curTime <- getCurrentTime curTime <- getCurrentTime
logLine $ BS.pack $ logLine $ BS.pack $

View File

@ -182,17 +182,17 @@ doQuit qmsg = do
-- * Command validation utilities -- * Command validation utilities
type ErrParam = (IrcReply, [IrcParam]) type ErrParam = (IrcReply, [IrcParam])
type IrcMonadErr = EitherT ErrParam IrcMonad type IrcMonadErr = ExceptT ErrParam IrcMonad
tellErr :: Either (IrcReply, [IrcParam]) a -> IrcMonad () tellErr :: Either (IrcReply, [IrcParam]) a -> IrcMonad ()
tellErr (Left (r, ps)) = void $ tellNumeric r ps tellErr (Left (r, ps)) = void $ tellNumeric r ps
tellErr _ = return () tellErr _ = return ()
runValidation :: IrcMonadErr () -> IrcMonad () runValidation :: IrcMonadErr () -> IrcMonad ()
runValidation = tellErr <=< runEitherT runValidation = tellErr <=< runExceptT
ensure :: Bool -> IrcReply -> [IrcParam] -> IrcMonadErr () ensure :: Bool -> IrcReply -> [IrcParam] -> IrcMonadErr ()
ensure p r ps = unless p $ left (r, ps) ensure p r ps = unless p $ throwE (r, ps)
ensureUse :: IrcMonad (Maybe a) -> ErrParam -> IrcMonadErr a ensureUse :: IrcMonad (Maybe a) -> ErrParam -> IrcMonadErr a
ensureUse u e = lift u >>= hoistEither . note e ensureUse u e = lift u >>= hoistEither . note e

View File

@ -128,7 +128,7 @@ handleJOIN msg@IrcMessage{..} = runValidation $ do
["0"] -> do cs <- useUserChans nn ["0"] -> do cs <- useUserChans nn
doPart msg{command=Left PART} (S.elems cs) Nothing doPart msg{command=Left PART} (S.elems cs) Nothing
-- No passwords were supplied -- No passwords were supplied
cs:[] -> doJoin msg $ zipParams (parseParamList cs) [] [cs] -> doJoin msg $ zipParams (parseParamList cs) []
-- Some number of passwords were supplied -- Some number of passwords were supplied
cs:ks:_ -> doJoin msg $ zipParams (parseParamList cs) (parseParamList ks) cs:ks:_ -> doJoin msg $ zipParams (parseParamList cs) (parseParamList ks)
@ -136,7 +136,7 @@ handlePART :: IrcMessage -> IrcMonad ()
handlePART msg@IrcMessage{..} = runValidation $ do handlePART msg@IrcMessage{..} = runValidation $ do
checkParamLength "PART" params 1 checkParamLength "PART" params 1
lift $ case params of lift $ case params of
cs:[] -> doPart msg (parseParamList cs) Nothing [cs] -> doPart msg (parseParamList cs) Nothing
cs:pm:_ -> doPart msg (parseParamList cs) (Just pm) cs:pm:_ -> doPart msg (parseParamList cs) (Just pm)
doJoin :: IrcMessage -> [(ChanKey, Maybe PassKey)] -> IrcMonad () doJoin :: IrcMessage -> [(ChanKey, Maybe PassKey)] -> IrcMonad ()
@ -173,7 +173,7 @@ handlePRIVMSG :: IrcMessage -> IrcMonad ()
handlePRIVMSG msg@IrcMessage{..} = do handlePRIVMSG msg@IrcMessage{..} = do
case params of case params of
[] -> tellNumeric err_norecipient [] [] -> tellNumeric err_norecipient []
_:[] -> tellNumeric err_notexttosend [] [_] -> tellNumeric err_notexttosend []
rsp:_:_ -> let rs = parseParamList rsp rsp:_:_ -> let rs = parseParamList rsp
in findReceivers rs >>= fwdMsg msg in findReceivers rs >>= fwdMsg msg
return () return ()

35
stack.yaml Normal file
View File

@ -0,0 +1,35 @@
# For more information, see: http://docs.haskellstack.org/en/stable/yaml_configuration.html
# Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2)
resolver: lts-5.0
# Local packages, usually specified by relative directory name
packages:
- '.'
# Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3)
extra-deps: []
# Override default flag values for local packages and extra-deps
flags: {}
# Extra package databases containing global packages
extra-package-dbs: []
# Control whether we use the GHC we find on the path
# system-ghc: true
# Require a specific version of stack, using version ranges
# require-stack-version: -any # Default
# require-stack-version: >= 1.0.0
# Override the architecture used by stack, especially useful on Windows
# arch: i386
# arch: x86_64
# Extra directories used by stack for building
# extra-include-dirs: [/path/to/dir]
# extra-lib-dirs: [/path/to/dir]
# Allow a newer minor version of GHC than the snapshot specifies
# compiler-check: newer-minor

View File

@ -2,21 +2,15 @@
module ParseTests where module ParseTests where
import Test.Tasty
import Test.Tasty.Hspec as HS import Test.Tasty.Hspec as HS
import Data.Attoparsec.ByteString.Char8 as P import Data.Attoparsec.ByteString.Char8 as P
import Data.ByteString.Char8 as C8
import Data.List
import Data.Ord
import Pipes.IRC.Message.Parse import Pipes.IRC.Message.Parse
import Pipes.IRC.Message.Render
import Pipes.IRC.Message.Types import Pipes.IRC.Message.Types
msgParseSpec :: Spec msgParseSpec :: Spec
msgParseSpec = do msgParseSpec =
describe "Parsing" $ do describe "Parsing" $ do
describe "parseMsgOrLine" $ do describe "parseMsgOrLine" $ do

View File

@ -6,11 +6,8 @@ import Test.Tasty
import Test.Tasty.Hspec as HS import Test.Tasty.Hspec as HS
import Test.Tasty.QuickCheck as QC import Test.Tasty.QuickCheck as QC
import Control.Applicative
import qualified Data.ByteString.Char8 as C8 import qualified Data.ByteString.Char8 as C8
import Data.List import Data.List
import Data.Monoid
import ParseTests import ParseTests
@ -20,18 +17,25 @@ import Pipes.IRC.Server.Types
import Pipes.IRC.Server.User import Pipes.IRC.Server.User
main :: IO () main :: IO ()
main = defaultMain tests main = do
ts <- tests
defaultMain ts
tests :: TestTree tests :: IO TestTree
tests = testGroup "Tests" [specs, userProperties, chanProperties] tests = do
sps <- specs
return $ testGroup "Tests" [sps, userProperties, chanProperties]
-- Hspec Tests -- Hspec Tests
specs :: TestTree specs :: IO TestTree
specs = testGroup "Specifications" specs = do
[ HS.testCase "Message Parsing" msgParseSpec mps <- HS.testSpec "Message Parsing" msgParseSpec
-- , HS.testCase "Message Rendering" msgRenderSpec -- mrs <- HS.testCase "Message Rendering" msgRenderSpec
] return $ testGroup "Specifications"
[ mps
-- , mrs
]
-- QuickCheck and SmallCheck properties -- QuickCheck and SmallCheck properties
{- {-