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/
.stack-work/
dist/

View File

@ -17,9 +17,18 @@ cabal-version: >=1.10
executable pipes-irc-server
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.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.MessageHandler
-- other-extensions:
@ -49,7 +58,17 @@ executable pipes-irc-server
test-suite tests
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
, mtl
, containers

View File

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

View File

@ -182,17 +182,17 @@ doQuit qmsg = do
-- * Command validation utilities
type ErrParam = (IrcReply, [IrcParam])
type IrcMonadErr = EitherT ErrParam IrcMonad
type IrcMonadErr = ExceptT ErrParam IrcMonad
tellErr :: Either (IrcReply, [IrcParam]) a -> IrcMonad ()
tellErr (Left (r, ps)) = void $ tellNumeric r ps
tellErr _ = return ()
runValidation :: IrcMonadErr () -> IrcMonad ()
runValidation = tellErr <=< runEitherT
runValidation = tellErr <=< runExceptT
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 u e = lift u >>= hoistEither . note e

View File

@ -128,7 +128,7 @@ handleJOIN msg@IrcMessage{..} = runValidation $ do
["0"] -> do cs <- useUserChans nn
doPart msg{command=Left PART} (S.elems cs) Nothing
-- No passwords were supplied
cs:[] -> doJoin msg $ zipParams (parseParamList cs) []
[cs] -> doJoin msg $ zipParams (parseParamList cs) []
-- Some number of passwords were supplied
cs:ks:_ -> doJoin msg $ zipParams (parseParamList cs) (parseParamList ks)
@ -136,7 +136,7 @@ handlePART :: IrcMessage -> IrcMonad ()
handlePART msg@IrcMessage{..} = runValidation $ do
checkParamLength "PART" params 1
lift $ case params of
cs:[] -> doPart msg (parseParamList cs) Nothing
[cs] -> doPart msg (parseParamList cs) Nothing
cs:pm:_ -> doPart msg (parseParamList cs) (Just pm)
doJoin :: IrcMessage -> [(ChanKey, Maybe PassKey)] -> IrcMonad ()
@ -173,7 +173,7 @@ handlePRIVMSG :: IrcMessage -> IrcMonad ()
handlePRIVMSG msg@IrcMessage{..} = do
case params of
[] -> tellNumeric err_norecipient []
_:[] -> tellNumeric err_notexttosend []
[_] -> tellNumeric err_notexttosend []
rsp:_:_ -> let rs = parseParamList rsp
in findReceivers rs >>= fwdMsg msg
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
import Test.Tasty
import Test.Tasty.Hspec as HS
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.Render
import Pipes.IRC.Message.Types
msgParseSpec :: Spec
msgParseSpec = do
msgParseSpec =
describe "Parsing" $ do
describe "parseMsgOrLine" $ do

View File

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