ginsu 0.8.1.1 → 0.8.2
raw patch · 30 files changed
+1183/−1056 lines, 30 filesdep +async
Dependencies added: async
Files
- Boolean/README +1/−1
- CacheIO.hs +2/−2
- ConfigFile.hs +15/−15
- Curses.hsc +9/−9
- EIO.hs +24/−24
- ErrorLog.hs +28/−28
- Filter.hs +30/−29
- Format.hs +8/−8
- Gale/Gale.hs +113/−79
- Gale/KeyCache.hs +130/−81
- Gale/Proto.hs +6/−6
- Gale/Puff.hs +88/−60
- GenUtil.hs +2/−2
- GinsuConfig.hs +14/−14
- Help.hs +6/−6
- KeyName.hs +3/−3
- Main.hs +217/−216
- Options.hs +9/−9
- PackedString.hs +10/−10
- RSA.hsc +25/−12
- Screen.hs +130/−130
- dist/build/ginsu/ginsu-tmp/ExampleConf.hs +9/−9
- dist/build/ginsu/ginsu-tmp/KeyHelpTable.hs +50/−50
- docs/Changelog.old +203/−203
- docs/ginsu.1 +15/−15
- docs/wiki.css +3/−3
- gen_keyhelp.prl +5/−5
- ginsu.cabal +18/−17
- ginsu.config.sample +9/−9
- my_curses.h +1/−1
Boolean/README view
@@ -1,3 +1,3 @@ -A general boolean algebra class and some instances for haskell. +A general boolean algebra class and some instances for haskell. The main module is Boolean.Algebra.
CacheIO.hs view
@@ -152,8 +152,8 @@ combineVal :: (Readable c1,Readable c2) => c1 a -> c2 b -> IO (ArbitraryReader (a,b)) combineVal sva svb = do let lsv = do- av <- readVal sva- bv <- readVal svb+ av <- readVal sva+ bv <- readVal svb return (av,bv) return $ ArbitraryReader lsv
ConfigFile.hs view
@@ -89,11 +89,11 @@ configFile fn = Config $ \k -> do cf <- readVal config_files_var case lookup fn cf of- Just cl -> basicLookup fn cl k- Nothing -> do- cl <- E.catch (fmap parseConfigFile $ readFile fn) (\(_ :: E.IOException) -> return [])- mapVal config_files_var ((fn,cl):)- basicLookup fn cl k+ Just cl -> basicLookup fn cl k+ Nothing -> do+ cl <- E.catch (fmap parseConfigFile $ readFile fn) (\(_ :: E.IOException) -> return [])+ mapVal config_files_var ((fn,cl):)+ basicLookup fn cl k configEnv :: Config configEnv = Config $ \k -> do@@ -106,17 +106,17 @@ instance Monoid Config where mempty = Config $ \_ -> return [] mappend (Config c1) (Config c2) = Config $ \s -> do- x <- c1 s- y <- c2 s- return (x ++ y)+ x <- c1 s+ y <- c2 s+ return (x ++ y) configShow :: [String] -> Config -> IO String configShow ss (Config c) = do v <- mapM c ss return $ unlines $ map p $ zip ss v where- p (k,((w,(k',v))):_) = k ++ " " ++ v ++ "\n# in " ++ w ++- if k' /= k then " as " ++ k' else ""- p (k,[]) = "#" ++ k ++ " Not Found."+ p (k,((w,(k',v))):_) = k ++ " " ++ v ++ "\n# in " ++ w +++ if k' /= k then " as " ++ k' else ""+ p (k,[]) = "#" ++ k ++ " Not Found." -- types of config sources:@@ -141,7 +141,7 @@ fixup (x:xs) = x: fixup xs fixup [] = [] bl s = let (n,r) = span isPropName (dropWhile isSpace s) in- if null n then [] else [(n,dropWhile isSpace r)]+ if null n then [] else [(n,dropWhile isSpace r)] {- @@ -166,9 +166,9 @@ configLookupBool k = do x <- configLookup k case x of- Just s | cond -> return True where- cond = (map toLower s) `elem` ["true", "yes", "on", "y", "t"]- _ -> return False+ Just s | cond -> return True where+ cond = (map toLower s) `elem` ["true", "yes", "on", "y", "t"]+ _ -> return False configLookup k = do
Curses.hsc view
@@ -251,10 +251,10 @@ i l = zipWithM_ f [1 .. n] l >> return n where n = length l -- the full intensity colors of a w*w*w rgb box rgbbox w = [ b+o |- b <- [0, w*w .. (w-2)*w*w ],- o <- [w-1, 2*w-1 .. (w-1)*w-1] -- blue- ++ [(w-1)*w .. w*w-1] ] -- green- ++ [(w-1)*w*w .. w*w*w-1] -- red+ b <- [0, w*w .. (w-2)*w*w ],+ o <- [w-1, 2*w-1 .. (w-1)*w-1] -- blue+ ++ [(w-1)*w .. w*w-1] ] -- green+ ++ [(w-1)*w*w .. w*w*w-1] -- red icp _ n | n < 2 = return 0 | n < 8 = initPair (Pair 1) defaultForeground bg >> return 1@@ -268,7 +268,7 @@ b <- hasColors when b $ do startColor- initColorPairs (Color 0)+ initColorPairs (Color 0) --when b useDefaultColors --cBreak True cbreak@@ -440,7 +440,7 @@ withColorId :: Window -> Int -> IO a -> IO a withColorId win c action = do ncp <- readIORef nColorPairs- if ncp == 0 + if ncp == 0 then action else withColor win (Pair $ 1 + c `mod` ncp) action @@ -694,8 +694,8 @@ withCursor :: CursorVisibility -> IO a -> IO a withCursor nv action = Control.Exception.bracket (cursSet (vis_c nv)) (\v -> case v of- (#const ERR) -> return 0- x -> cursSet x) (\_ -> action)+ (#const ERR) -> return 0+ x -> cursSet x) (\_ -> action) @@ -967,7 +967,7 @@ data ButtonEvent = ButtonPressed Int | ButtonReleased Int | ButtonClicked Int | ButtonDoubleClicked Int | ButtonTripleClicked Int | ButtonShift | ButtonControl | ButtonAlt- deriving(Eq,Show)+ deriving(Eq,Show) withMouseEventMask :: [ButtonEvent] -> IO a -> IO a
EIO.hs view
@@ -24,29 +24,29 @@ hGetRawContents h = do a <- newArray_ (1,bufSize) getall a where- getall a = do- sz <- hGetArray h a bufSize- av <- getElems a- if sz == 0 then return [] else do- r <- getall a- return (take sz av ++ r)+ getall a = do+ sz <- hGetArray h a bufSize+ av <- getElems a+ if sz == 0 then return [] else do+ r <- getall a+ return (take sz av ++ r) hPutRawContents :: Handle -> [Word8] -> IO () hPutRawContents h xs = do a <- newArray_ (1,bufSize) prc a h xs where- prc _ _ [] = return ()- prc a h xs@(_:_) = do- let (ys,zs) = splitAt bufSize xs- if null zs- then do -- work around a ghc bug in hPutArray- let lys = length ys- a' <- newListArray (1,lys) ys- hPutArray h a' lys- else do- zipWithM_ (writeArray a) [1..] ys- hPutArray h a bufSize- prc a h zs+ prc _ _ [] = return ()+ prc a h xs@(_:_) = do+ let (ys,zs) = splitAt bufSize xs+ if null zs+ then do -- work around a ghc bug in hPutArray+ let lys = length ys+ a' <- newListArray (1,lys) ys+ hPutArray h a' lys+ else do+ zipWithM_ (writeArray a) [1..] ys+ hPutArray h a bufSize+ prc a h zs putRaw :: Handle -> [Word8] -> IO ()@@ -93,14 +93,14 @@ memoIO ioa = do v <- readIORef var case v of- Just x -> return x- Nothing -> do- x <- ioa- writeIORef var (Just x)- return x+ Just x -> return x+ Nothing -> do+ x <- ioa+ writeIORef var (Just x)+ return x where {-# NOTINLINE var #-}- var = unsafePerformIO $ newIORef Nothing+ var = unsafePerformIO $ newIORef Nothing getTempFileName :: IO String getTempFileName = do
ErrorLog.hs view
@@ -82,12 +82,12 @@ -- to stderr. note, that while the errorlog will function properly with concurrent -- applications, a single errorlog is shared by all threads. withErrorLog :: String -- ^ filename of log- -> IO a -- ^ action to execute with logging to file- -> IO a+ -> IO a -- ^ action to execute with logging to file+ -> IO a withErrorLog "-" action = bracket (swapMVar ior stderr) (swapMVar ior) (\_ -> action) withErrorLog fn action = E.bracket (openFile fn WriteMode) hClose $ \h -> do- hSetBuffering h LineBuffering- bracket (swapMVar ior h) (swapMVar ior) (\_ -> action)+ hSetBuffering h LineBuffering+ bracket (swapMVar ior h) (swapMVar ior) (\_ -> action) -- | sets log level to new value, returns old log level. setLogLevel :: LogLevel -> IO LogLevel@@ -97,14 +97,14 @@ -- If the action throws an exception, it will be logged along with the -- exit entry. withStartEndEntrys :: String -- ^ title to use in log entries- -> IO a -- ^ action to execute- -> IO a+ -> IO a -- ^ action to execute+ -> IO a withStartEndEntrys n action = do gct >>= \ct -> putLogLn (ct ++ " " ++ n ++ " Starting") handle- (\(e :: SomeException) -> gct >>= \ct -> putLogException (ct ++ " " ++ n ++ " Ending due to Exception:" ) e >> throw e)- (action >>= \r -> gct >>= \ct -> putLogLn (ct ++ " " ++ n ++ " Ending") >> return r) where- gct = getClockTime >>= \ct -> return $ "[" ++ show ct ++ "]"+ (\(e :: SomeException) -> gct >>= \ct -> putLogException (ct ++ " " ++ n ++ " Ending due to Exception:" ) e >> throw e)+ (action >>= \r -> gct >>= \ct -> putLogLn (ct ++ " " ++ n ++ " Ending") >> return r) where+ gct = getClockTime >>= \ct -> return $ "[" ++ show ct ++ "]" -- | run an action, printing an error message to the log if it ends with an exception.@@ -112,9 +112,9 @@ withErrorMessage :: String -> IO a -> IO a withErrorMessage n action = do handle- (\(e :: SomeException) -> gct >>= \ct -> putLogLn (normalize n ++ ct ++ " Ending due to Exception:\n" ++ indent 4 (show e) ) >> throw e )- action where- gct = getClockTime >>= \ct -> return $ "[" ++ show ct ++ "]"+ (\(e :: SomeException) -> gct >>= \ct -> putLogLn (normalize n ++ ct ++ " Ending due to Exception:\n" ++ indent 4 (show e) ) >> throw e )+ action where+ gct = getClockTime >>= \ct -> return $ "[" ++ show ct ++ "]" -- | set routine with same signature as 'hPutStr' to use for writing to log.@@ -171,7 +171,7 @@ -- | attempt an action, add a log entry with the exception if it -- fails attemptIO :: IO a -> IO ()-attemptIO action = E.catch (action >> return ()) +attemptIO action = E.catch (action >> return ()) (\(e :: IOException) -> putLogException "attempt ExceptionCaught" e) tryMapM :: (a -> IO b) -> [a] -> IO [b]@@ -194,9 +194,9 @@ -- | Retry an action until it succeeds. retryIO :: Float -- ^ number of seconds to pause between trys- -> String -- ^ string to annotate log entries with when retrying- -> IO a -- ^ action to retry- -> IO a+ -> String -- ^ string to annotate log entries with when retrying+ -> IO a -- ^ action to retry+ -> IO a retryIO delay n action = do handle (\(e :: IOException) -> putLogException (n ++ " (retrying in " ++ show delay ++ "s):") e >> threadDelay (floor $ 1000000 * delay) >> retryIO delay n action) action @@ -213,15 +213,15 @@ v <- newEmptyMVar ts <- mapM (forkIO . f v) arms g v ts where- f v arm = do- t <- myThreadId- r <- tryIO arm- putMVar v (t,r)- g v ts = do- (t,r) <- takeMVar v- let ts' = delete t ts- case r of- Left e -> if null ts' then throw e else g v ts'- Right x -> do- mapM_ killThread ts'- return x+ f v arm = do+ t <- myThreadId+ r <- tryIO arm+ putMVar v (t,r)+ g v ts = do+ (t,r) <- takeMVar v+ let ts' = delete t ts+ case r of+ Left e -> if null ts' then throw e else g v ts'+ Right x -> do+ mapM_ killThread ts'+ return x
Filter.hs view
@@ -59,7 +59,7 @@ parseTwiddle = do char '~' f <- satisfy isAlpha- option ':' (char ':')+ option ':' (char ':') s <- string spaces z f s@@ -94,43 +94,43 @@ parseFilter :: Monad m => String -> m Filter parseFilter = parser (between spaces eof rmp) where rmp = do- fa <- mp- r <- rmp'- case r of- [] -> return fa- _ -> return $ FilterOr (fa:r)+ fa <- mp+ r <- rmp'+ case r of+ [] -> return fa+ _ -> return $ FilterOr (fa:r) rmp' = (do- char ';'- spaces- v <- mp- r <- rmp'- return (v:r)) <|> return []+ char ';'+ spaces+ v <- mp+ r <- rmp'+ return (v:r)) <|> return [] mp = many1 fp >>= \v -> case v of- [x] -> return x- xs -> return $ FilterAnd xs+ [x] -> return x+ xs -> return $ FilterAnd xs fp = nf <|> flt <|> pr <|> bool <|> do s <- (token string); liftM (FilterRegex f_messageBody) (compileRx s) pr = do- char '('- spaces- v <- rmp- char ')'- spaces- return v+ char '('+ spaces+ v <- rmp+ char ')'+ spaces+ return v nf = char '!' >> liftM FilterNot fp string = qstring <|> many1 (noneOf " \t\n~'!();%") qstring = between (char '\'') (char '\'') $ many ((char '\'' >> char '\'' >> return '\'') <|> noneOf "'") bool = do- char '%'- c <- sat isAlpha- spaces- return $ b c+ char '%'+ c <- sat isAlpha+ spaces+ return $ b c flt = do- char '~'- c <- sat isAlpha- option ':' (char ':')- s <- string- spaces- z c s+ char '~'+ c <- sat isAlpha+ option ':' (char ':')+ s <- string+ spaces+ z c s z 'a' s = return $ FilterAuthor s z 'c' s = return $ FilterCategory (catParseNew s) z 't' s = return $ FilterCategory (catParseNew s) -- TODO@@ -173,6 +173,7 @@ f _ = [] -} +siglookup c (RequestingKey _ (Key n _) _ _:_) | c == n = True siglookup c (Unverifyable (Key n _):_) | c == n = True siglookup c (Signed (Key n _):_) | c == n = True siglookup c (_:xs) = siglookup c xs
Format.hs view
@@ -114,19 +114,19 @@ fmt :: String -> [F] -> String fmt ('%':'%':xs) fs = '%':fmt xs fs fmt ('%':xs) (f:fs) = case xs5 of- ('\'':cs) -> let (a,b) = gs "" cs in formatString a bp ++ fmt b fs- (c:cs) -> f (bp {patternChar = c}) ++ fmt cs fs- [] -> []+ ('\'':cs) -> let (a,b) = gs "" cs in formatString a bp ++ fmt b fs+ (c:cs) -> f (bp {patternChar = c}) ++ fmt cs fs+ [] -> [] where bp = pattern {patternSub = ss, patternFlags = flags, patternWidth = w, patternPrecision = p} (flags,xs2) = span (`elem` "# 0-+'") xs (w,xs3) = grabNum xs2 (p,xs4) = case xs3 of- ('.':xs) -> grabNum xs- xs -> (Nothing, xs)+ ('.':xs) -> grabNum xs+ xs -> (Nothing, xs) (ss,xs5) = case xs4 of- ('(':xs) -> let (u,v) = span (/= ')') xs in ([u],tail v)- xs -> ([],xs)+ ('(':xs) -> let (u,v) = span (/= ')') xs in ([u],tail v)+ xs -> ([],xs) grabNum xs = let (u,v) = span isDigit xs in if null u then (Nothing,v) else (Just (read u),v) gs x ('\'':'\'':cs) = gs ('\'':x) cs gs x ('\'':cs) = (reverse x,cs)@@ -154,7 +154,7 @@ hex = "0123456789abcdef" foo 0 = "" foo x = let (u,v) = x `divMod` (toInteger base) in- (hex !! fromIntegral v) : foo u+ (hex !! fromIntegral v) : foo u childFmt :: Pattern -> [F] -> String
Gale/Gale.hs view
@@ -21,8 +21,10 @@ import Data.List import Data.Maybe import System.Time+import System.Timeout (timeout) import Control.Concurrent+import Control.Concurrent.Async (async, wait) import Control.Exception as E import Data.Bits import Network.BSD@@ -136,13 +138,13 @@ connectTo hostname port = do --proto <- getProtocolNumber "tcp" bracketOnError- (socket AF_INET Stream 6)- (sClose) -- only done if there's an error+ (socket AF_INET Stream 6)+ (sClose) -- only done if there's an error (\sock -> do- he <- getHostByName hostname- connect sock (SockAddrInet port (hostAddress he))- socketToHandle sock ReadWriteMode- )+ he <- getHostByName hostname+ connect sock (SockAddrInet port (hostAddress he))+ socketToHandle sock ReadWriteMode+ ) @@ -157,12 +159,12 @@ emptyPuffer :: MVar Handle -> IO () emptyPuffer hv = repeatM_ (threadDelay 30000000 >> sendEmptyPuff) where- sendEmptyPuff = withMVar hv $ \h -> do- putWord32 h 0- putWord32 h 8- putWord32 h 0- putWord32 h 0- hFlush h+ sendEmptyPuff = withMVar hv $ \h -> do+ putWord32 h 0+ putWord32 h 8+ putWord32 h 0+ putWord32 h 0+ hFlush h connectThread :: GaleContext -> [String] -> MVar Handle -> IO () connectThread gc _ hv = retryIO 5.0 ("ConnectionError") doit where@@ -171,30 +173,52 @@ swapMVar (connectionStatus gc) $ Left $ "Attempting to connect to: " ++ unwords ds trySeveral (map attemptConnect ds) doit = bracket openHandle (hClose . fst) $ \(h,hn) -> do- putWord32 h 1- _ <- readWord32 h -- version+ putWord32 h 1+ _ <- readWord32 h -- version sendGimme gc swapMVar (connectionStatus gc) $ Right hn- bracket_ (putMVar hv h) (takeMVar hv) $- bracket (forkIO (emptyPuffer hv)) killThread $ \_ -> repeatM_ $ do- w <- readWord32 h- l <- readWord32 h+ bracket_ (putMVar hv h) (takeMVar hv) $+ bracket (forkIO (emptyPuffer hv)) killThread $ \_ -> repeatM_ $ do+ w <- readWord32 h+ l <- readWord32 h bs <- LBS.hGet h (fromIntegral l)- when (w == 0) $ do+ when (w == 0) $ do let hash = sha1 bs (catl,puff) = runGet decodePuff bs cat = mapMaybe parseCategoryOld (spc catl) ct <- getClockTime let ef = \xs -> ((fromString "_ginsu.timestamp",FragmentTime ct):(fromString "_ginsu.spumbuster", FragmentText (packString (bsToHex hash))):xs) p' <- galeDecryptPuff gc Puff { signature = [], cats = cat, fragments = ef puff}- writeChan (channel gc) $ p'- case getFragmentData p' f_answerKey' of+ np <- case [(kh, k, data_, sig)+ | RequestingKey kh k data_ sig <- signature p'] of+ [] -> return p'+ (kh, k, data_, sig):_ -> do+ res <- timeout 4000000 $ wait kh+ let unver = p' { signature = [Unverifyable k] }+ case res of+ Just x -> case x of+ DestEncrypted (k':_) -> do+ mkey <- verifySignature k' data_ sig+ return $ p' { signature = [mkey] }+ _ -> return unver+ Nothing -> return unver+ writeChan (channel gc) np+ case getFragmentData np f_answerKey' of Just d -> putKey (keyCache gc) d Nothing -> return ()- case (cats p',getFragmentString p' f_answerKeyError') of+ case (cats np,getFragmentString np f_answerKeyError') of ([Category (n,d)],Just _) | "_gale.key." `isPrefixOf` n -> noKey (keyCache gc) (catShowNew $ Category (drop 10 n,d)) (_,_) -> return ()+ maybeReplyToKeyQuery gc np +maybeReplyToKeyQuery :: GaleContext -> Puff -> IO ()+maybeReplyToKeyQuery gc p | Just kn <- getFragmentString p f_questionKey = do+ let kn' = unpackPS kn+ mkb <- getPubKeyBytes (keyCache gc) kn'+ d <- createPuff gc False $ keyResponsePuff mkb kn'+ putLog LogDebug $ "sending reply for: " ++ kn'+ retryIO 3.0 "error sending puff" $ withMVar (gHandle gc) $ \h -> LBS.hPut h d >> hFlush h+maybeReplyToKeyQuery _ _ = return () decodePuff :: Get (String,FragmentList) decodePuff = do@@ -242,11 +266,13 @@ collectSigs :: [Signature] -> ([String],[String]) collectSigs ss = liftT2 (snub, snub) $ cs ss ([],[]) where- cs ((Unverifyable _):_) _ = error "attempt to create unverifyable puff"- cs (Signed (Key k _):ss) (ks,es) = cs ss (k:ks,es)- cs (Encrypted es':ss) (ks,es) = cs ss (ks,es' ++ es)- cs [] x = x-+ cs sig x@(ks,es) = case sig of+ (RequestingKey _ _ _ _):_ -> lose+ (Unverifyable _):_ -> lose+ (Signed (Key k _)):ss -> cs ss (k:ks,es)+ (Encrypted es':ss) -> cs ss (ks,es' ++ es)+ [] -> x+ lose = error "attempt to create unverifiable puff" tagWord :: Int -> Put -> Put tagWord i p = putWord32be (fromIntegral i) >> p@@ -273,14 +299,14 @@ evaluate $ runPut pd createPuff gc will p | (kn:_,es) <- collectSigs (signature p) = do getPrivateKey (keyCache gc) kn >>= \v -> case v of- Nothing -> createPuff gc will $ p {signature = []}- Just (Key _ kfl,pkey) -> do- sfl <- case fragmentString f_keyOwner kfl of- Just o -> return [(f_messageSender, FragmentText o)]- Nothing -> return []- let fl = runPutBS $ tagWord 0 (putFragments (fragments p `mergeFrags` sfl))- sig <- signAll pkey fl- let sd = runPutBS $ do+ Nothing -> createPuff gc will $ p {signature = []}+ Just (Key _ kfl,pkey) -> do+ sfl <- case fragmentString f_keyOwner kfl of+ Just o -> return [(f_messageSender, FragmentText o)]+ Nothing -> return []+ let fl = runPutBS $ tagWord 0 (putFragments (fragments p `mergeFrags` sfl))+ sig <- signAll pkey fl+ let sd = runPutBS $ do putByteString bs_signature_magic1 tagWord (BS.length sig) (putByteString sig) putByteString (BS.pack pubkey_magic3)@@ -288,7 +314,7 @@ fd = tagWord (BS.length sd) (putByteString sd) >> putByteString fl fragments = [(f_securitySignature,FragmentData (runPutBS fd))] nfragments <- cryptFragments gc es fragments- createPuff gc will $ p {signature = [], fragments = nfragments }+ createPuff gc will $ p {signature = [], fragments = nfragments } createPuff _ _ _ = error "createPuff: invalid arguments" cryptFragments :: GaleContext -> [String] -> FragmentList -> IO FragmentList@@ -329,8 +355,8 @@ putFragments fl = mapM_ f fl where f (s',f) = putWord32be t >> putWord32be (fromIntegral $ LBS.length nxs) >> putLazyByteString nxs where nxs = runPut (n >> xs)- (t, xs) = g f- n = putWord32be (fromIntegral $ length s) >> (putGaleString s)+ (t, xs) = g f+ n = putWord32be (fromIntegral $ length s) >> (putGaleString s) s = toString s' g (FragmentData ws) = (1, putByteString ws) g (FragmentText s) = (0, putGaleString (unpackPS s))@@ -351,11 +377,11 @@ bl [_] = [] bl (x:xs) = x:bl xs p = do- char '@'- d <- many (noneOf "/")- parseExact "/user/"- c <- parseRest- return (Category (con (bl c),d))+ char '@'+ d <- many (noneOf "/")+ parseExact "/user/"+ c <- parseRest+ return (Category (con (bl c),d)) catShowOld :: Category -> String catShowOld (Category (c,d)) = "@" ++ d ++ "/user/" ++ con c ++ "/" where@@ -368,35 +394,55 @@ -- Security routines -------------------- +verifySignature :: Key -> BS.ByteString -> BS.ByteString -> IO Signature+verifySignature k data_ sig = do+ pkey <- keyToPkey k+ rv <- verifyAll pkey data_ sig+ return $ (if rv then Signed else Unverifyable) k+ galeDecryptPuff :: GaleContext -> Puff -> IO Puff galeDecryptPuff gc p = handle (\(_ :: IOException) -> return p) $ galeDecryptPuff' gc p galeDecryptPuff' gc p | (Just xs) <- getFragmentData p f_securitySignature = do let (l,xs') = xdrReadUInt (BS.unpack xs)- (sb,xs'') = xdrReadUInt (drop 4 xs')- fl = (decodeFragments $ drop (fromIntegral l + 4) xs') ++ [f|f <- fragments p, fst f /= f_securitySignature]- key <- maybe (fail "parseKey") return $ parseKey $ take (fromIntegral (l - (8 + sb))) (drop (fromIntegral sb) xs'')- galeDecryptPuff' gc $ p {signature = (Unverifyable key): signature p, fragments = fl}+ (sb,xs'') = xdrReadUInt (drop 4 xs')+ fl = (decodeFragments $ drop (fromIntegral l + 4) xs') ++ [f | f <- fragments p, fst f /= f_securitySignature]+ sigoff = 12 -- skip length hdr (4), sig magic (4), sig len (4)+ siglen = fromIntegral sb+ keylen = fromIntegral l - (8 + siglen)+ keyoff = sigoff + siglen -- key directly follows sig+ sig = BS.take siglen $ BS.drop sigoff xs+ data_ = BS.drop (keyoff + keylen) xs+ key <- maybe (fail "parseKey") return $ parseKey $ take keylen (drop siglen xs'')+ let (Key kn _) = key+ kgc <- getKey (keyCache gc) kn+ mkey <- case kgc of+ Nothing -> do+ let senderc = catParseNew kn+ h <- async (findDest gc senderc)+ return $ RequestingKey h key data_ sig+ Just k -> verifySignature k data_ sig+ galeDecryptPuff' gc $ p {signature = mkey: signature p, fragments = fl} galeDecryptPuff' gc p | (Just xs) <- getFragmentData p f_securityEncryption = do (cd,ks) <- maybe (fail "parseKey") return $ parser pe (BS.unpack xs) dfl <- firstIO (map (td' (BS.pack cd)) [ (BS.pack x,y,BS.pack z) | (x,y,z) <- ks])- let dfl' = dfl ++ [f|f <- fragments p, fst f /= f_securityEncryption]+ let dfl' = dfl ++ [f | f <- fragments p, fst f /= f_securityEncryption] galeDecryptPuff' gc $ p {signature = (Encrypted (map (\(_,n,_) -> n) ks)): signature p, fragments = dfl'} where- pe = (parseExact cipher_magic1 >> pr parseNullString) <|> (parseExact cipher_magic2 >> pr parseLenString)- pk pkname iv = do- kname <- pkname- keydata <- parseLenData- return $ (iv,kname,keydata)- pr pkname = do- iv <- parseSome 8- keycount <- parseIntegral32- ks <- replicateM keycount (pk pkname iv)- xs <- parseRest- return (xs,ks)- td' cd (iv,kname,keydata) = do- Just (_,pkey) <- getPrivateKey (keyCache gc) kname- dd <- decryptAll keydata iv pkey cd- --let dfl = decodeFragments (drop 4 (BS.unpack dd))- return $ runGet decodeFrags (LBS.fromChunks [BS.drop 4 dd])+ pe = (parseExact cipher_magic1 >> pr parseNullString) <|> (parseExact cipher_magic2 >> pr parseLenString)+ pk pkname iv = do+ kname <- pkname+ keydata <- parseLenData+ return $ (iv,kname,keydata)+ pr pkname = do+ iv <- parseSome 8+ keycount <- parseIntegral32+ ks <- replicateM keycount (pk pkname iv)+ xs <- parseRest+ return (xs,ks)+ td' cd (iv,kname,keydata) = do+ Just (_,pkey) <- getPrivateKey (keyCache gc) kname+ dd <- decryptAll keydata iv pkey cd+ --let dfl = decodeFragments (drop 4 (BS.unpack dd))+ return $ runGet decodeFrags (LBS.fromChunks [BS.drop 4 dd]) galeDecryptPuff' _ x = return x @@ -465,18 +511,6 @@ r k = fk (map unpackPS (getFragmentStrings k f_keyMember) ++ ss) ((s,Just k):xs) -} -data Dest = DestPublic | DestUnknown [String] | DestEncrypted [Key]- deriving(Eq,Show)--instance Monoid Dest where- mempty = DestEncrypted []- DestUnknown a `mappend` DestUnknown b = DestUnknown (a ++ b)- DestUnknown a `mappend` _ = DestUnknown a- _ `mappend` DestUnknown a = DestUnknown a- DestPublic `mappend` _ = DestPublic- _ `mappend` DestPublic = DestPublic- DestEncrypted a `mappend` DestEncrypted b = DestEncrypted (a ++ b)- normalizeDest DestPublic = DestPublic normalizeDest (DestUnknown xs) = DestUnknown $ snub xs normalizeDest (DestEncrypted xs) = DestEncrypted $ snub xs@@ -577,13 +611,13 @@ when (n /= 4) $ fail "short read." [b1,b2,b3,b4] <- getElems a return $ (fromIntegral b4) .|. (fromIntegral b3 `shiftL` 8) .|.- (fromIntegral b2 `shiftL` 16) .|. (fromIntegral b1 `shiftL` 24)+ (fromIntegral b2 `shiftL` 16) .|. (fromIntegral b1 `shiftL` 24) galeEncodeString :: String -> [Word8] galeEncodeString cs = concatMap (f . ord) (concat $ map (\c -> if c == '\n' then "\r\n" else [c]) cs) where f x = (b1:b2:[]) where- b1 = fromIntegral $ (x `shiftR` 8) .&. 0xFF- b2 = fromIntegral $ x .&. 0xFF+ b1 = fromIntegral $ (x `shiftR` 8) .&. 0xFF+ b2 = fromIntegral $ x .&. 0xFF --------------
Gale/KeyCache.hs view
@@ -12,7 +12,10 @@ putKey, noKey, numberKeys,- keyRequestPuff+ keyRequestPuff,+ keyToPkey,+ getPubKeyBytes,+ keyResponsePuff ) where @@ -63,23 +66,29 @@ data KeyCache = KeyCache { pkeyCache :: !(MVar (Map.Map String (Weak (Key,EvpPkey)))), kkeyCache :: !(MVar (Map.Map String (Weak Key))),+ pubkeyCache :: !(MVar (Map.Map String (Weak BS.ByteString))), galeDir :: String } numberKeys kc = fmap Map.size $ readMVar (kkeyCache kc) -keyIsPubKey k = (hasFragment k f_rsaExponent)+keyIsPubKey :: HasFragmentList a => a -> Bool+keyIsPubKey k = not (hasFragment k f_rsaPrivateExponent)+ && hasFragment k f_rsaExponent+keyIsPrivKey :: HasFragmentList a => a -> Bool keyIsPrivKey k = (hasFragment k f_rsaPrivateExponent)+keyIsPublic :: HasFragmentList a => a -> Bool keyIsPublic k = any nullPS $ getFragmentStrings k f_keyMember newKeyCache galeDir = do pk <- newMVar Map.empty kk <- newMVar Map.empty- return KeyCache { {- keyCache = kc, publicKeyCache = pkc,-} galeDir = galeDir, pkeyCache = pk, kkeyCache = kk }+ pbk <- newMVar Map.empty+ return KeyCache { {- keyCache = kc, publicKeyCache = pkc,-} galeDir = galeDir, pkeyCache = pk, kkeyCache = kk, pubkeyCache = pbk } keyToRSAElems :: Monad m => Key -> m (RSAElems BS.ByteString) keyToRSAElems fl = do- if not (keyIsPubKey fl) then fail "key does not have bits" else do+ if not (keyIsPrivKey fl) then fail "key does not have bits" else do n <- getFragmentData fl f_rsaModulus e <- getFragmentData fl f_rsaExponent if not (keyIsPrivKey fl) then@@ -185,6 +194,37 @@ v' <- mkWeakPtr v' Nothing return (Map.insert kn v' kkeyCache, ()) +-- XXX duplication; the key cache should store a ByteString of the pubkey too so+-- that we don't need this separate function+getPubKeyBytes :: KeyCache -> String -> IO (Maybe BS.ByteString)+getPubKeyBytes kc kn = modifyMVar (pubkeyCache kc) f where+ f pkc | Just v <- Map.lookup kn pkc = do+ v' <- deRefWeak v+ case v' of+ Just _ -> return (pkc, v')+ Nothing -> g pkc+ f pkc = g pkc+ g pkc = do+ v <- tryIO getFromDisk+ case v of+ Left _ -> return (pkc, Nothing)+ Right v' -> do+ v'' <- mkWeakPtr v' Nothing+ return (Map.insert kn v'' pkc, Just v')+ getFromDisk = do+ let pp = galeDir kc ++ "/auth/private/"+ knames = pp ++ kn ++ ".gpub"+ gf fn = readRawFile fn >>= \xs -> do+ let pk = BS.pack xs+ k = parseKey xs+ return (fn, pk, k)+ xs <- tryIO $ gf knames+ case xs of+ Left _ -> lose+ Right (_,bs,mk) | Just _ <- mk -> return bs+ Right _ -> lose+ where+ lose = ioError $ userError "bad key" getKey :: KeyCache -> String -> IO (Maybe Key) getKey kc kn = modifyMVar (kkeyCache kc) f where@@ -195,7 +235,7 @@ Nothing -> g kkeyCache f kkeyCache = g kkeyCache g kkeyCache = do- v <- tryIO getFromDisk+ v <- tryIO getFromDisk case v of Left _ -> return (kkeyCache, Nothing) Right v' -> do@@ -212,9 +252,9 @@ let ks = [ k | (_,Just k@(Key n _)) <- xs, kn == n] let nk = foldr (\(Key _ fl) (Key n fl') -> Key n (fl `mergeFrags` fl')) (Key kn []) ks --(key_c, fn) <- (first gn)- --key <- parseKey key_c- --rsa <- pubKeyToRSA key- --pkey <- pkeyNewRSA rsa+ --key <- parseKey key_c+ --rsa <- pubKeyToRSA key+ --pkey <- pkeyNewRSA rsa if null (getFragmentList nk) then ioError $ userError "bad key" else return nk flipLocalPart :: String -> String@@ -231,6 +271,13 @@ s' = flipLocalPart s Category (n,d) = catParseNew s +keyResponsePuff :: Maybe BS.ByteString -> String -> Puff+keyResponsePuff kb s = emptyPuff { cats = [Category ("_gale.key." ++ n, d)], fragments = [resp]} where+ resp = case kb of+ Just x -> (f_answerKey', FragmentData x)+ Nothing -> (f_answerKeyError', FragmentText $ packString $ "cannot find " ++ s)+ Category (n,d) = catParseNew s+ --la xs = listArray (0, length xs - 1) xs --la xs = BS.pack xs @@ -241,7 +288,7 @@ b3 <- get b4 <- get return $ (fromIntegral b4) .|. (fromIntegral b3 `shiftL` 8) .|.- (fromIntegral b2 `shiftL` 16) .|. (fromIntegral b1 `shiftL` 24)+ (fromIntegral b2 `shiftL` 16) .|. (fromIntegral b1 `shiftL` 24) parseWord16 :: ReadP Word16 parseWord16 = do@@ -261,13 +308,13 @@ privatePrimeExponentD <- splitRLE (galeRSAPrimeLen * 2) privateCoefficientD <- splitRLE galeRSAPrimeLen let fl = [("rsa.modulus",FragmentData modulusD),- ("rsa.exponent",FragmentData exponentD),- ("rsa.private.exponent",FragmentData privateExponentD),- ("rsa.private.prime",FragmentData privatePrimeD),- ("rsa.private.prime.exponent",FragmentData privatePrimeExponentD),- ("rsa.private.coefficient",FragmentData privateCoefficientD),- ("rsa.bits", FragmentInt (fromIntegral bits))- ]+ ("rsa.exponent",FragmentData exponentD),+ ("rsa.private.exponent",FragmentData privateExponentD),+ ("rsa.private.prime",FragmentData privatePrimeD),+ ("rsa.private.prime.exponent",FragmentData privatePrimeExponentD),+ ("rsa.private.coefficient",FragmentData privateCoefficientD),+ ("rsa.bits", FragmentInt (fromIntegral bits))+ ] return [ (fromString x,y) | (x,y) <- fl] {- (bits,ys) = xdrReadUInt xs@@ -298,60 +345,62 @@ keyParse :: ReadP Key keyParse = choice [ppk1,ppk2,ppk3,pk1,pk2,pk3] where ppk1 = do- string private_magic1- kn <- fmap flipLocalPart parseNullString- fl <- keyDecode12- return $ Key kn fl+ string private_magic1+ kn <- fmap flipLocalPart parseNullString+ fl <- keyDecode12+ return $ Key kn fl ppk2 = do- string private_magic2- kn <- fmap flipLocalPart parseLenString- fl <- keyDecode12- return $ Key kn fl+ string private_magic2+ kn <- fmap flipLocalPart parseLenString+ fl <- keyDecode12+ return $ Key kn fl ppk3 = do- string private_magic3- kn <- fmap flipLocalPart parseLenString- fl <- toParser decodeFrags- return $ Key kn fl+ string private_magic3+ kn <- fmap flipLocalPart parseLenString+ fl <- toParser decodeFrags+ return $ Key kn fl pk1 = do- string pubkey_magic1- kn <- fmap flipLocalPart parseNullString- (eof >> return (Key kn [])) +++ do- comment <- parseNullString- fl <- parsePublic12- skipMany get -- the signature- return $ Key kn ([(f_keyOwner, FragmentText (packString comment))] ++ fl)+ string pubkey_magic1+ kn <- fmap flipLocalPart parseNullString+ (eof >> return (Key kn [])) +++ do+ comment <- parseNullString+ fl <- parsePublic12+ skipMany get -- the signature+ return $ Key kn ([(f_keyOwner, FragmentText (packString comment))] ++ fl) pk2 = do- string pubkey_magic2- kn <- fmap flipLocalPart parseLenString- (eof >> return (Key kn [])) +++ do- comment <- parseLenString- fl' <- parsePublic12- let fl = ((f_keyOwner, FragmentText (packString comment)):fl')- (eof >> return (Key kn fl)) +++ do- ts <- replicateM 16 get- te <- replicateM 16 get+ string pubkey_magic2+ kn <- fmap flipLocalPart parseLenString+ (eof >> return (Key kn [])) +++ do+ comment <- parseLenString+ fl' <- parsePublic12+ let fl = ((f_keyOwner, FragmentText (packString comment)):fl')+ (eof >> return (Key kn fl)) +++ do+ ts <- replicateM 16 get+ te <- replicateM 16 get skipMany get- --_signature <- parseRest- return $ Key kn $ fl ++ [(f_keySigned,FragmentTime (decodeTime ts)), (f_keyExpires,FragmentTime (decodeTime te))]+ --_signature <- parseRest+ return $ Key kn $ fl ++ [(f_keySigned,FragmentTime (decodeTime ts)), (f_keyExpires,FragmentTime (decodeTime te))] pk3 = do- string pubkey_magic3- kn <- fmap flipLocalPart parseLenString- fl <- toParser decodeFrags- return $ Key kn fl+ string pubkey_magic3+ kn <- fmap flipLocalPart parseLenString+ fl <- toParser decodeFrags+ return $ Key kn fl parsePublic12 = do- bits <- parseIntegral32- --modulus <- (MkP (\x -> Just (splitRLE galeRSAModulusLen x)))- --exponent <- (MkP (\x -> Just (splitRLE galeRSAModulusLen x)))- modulus <- splitRLE galeRSAModulusLen- exponent <- splitRLE galeRSAModulusLen- return [(f_rsaModulus, FragmentData modulus),- (f_rsaExponent, FragmentData exponent),- (f_rsaBits, FragmentInt $ fromIntegral bits)]+ bits <- parseIntegral32+ --modulus <- (MkP (\x -> Just (splitRLE galeRSAModulusLen x)))+ --exponent <- (MkP (\x -> Just (splitRLE galeRSAModulusLen x)))+ modulus <- splitRLE galeRSAModulusLen+ exponent <- splitRLE galeRSAModulusLen+ return [(f_rsaModulus, FragmentData modulus),+ (f_rsaExponent, FragmentData exponent),+ (f_rsaBits, FragmentInt $ fromIntegral bits)] -parser :: ReadP a -> BS.ByteString -> Maybe a+parser :: Show a => ReadP a -> BS.ByteString -> Maybe a parser p bs = case readP_to_S p bs of- [(a,bs)] | BS.null bs -> Just a+ x:xs ->+ let (a,bs) = if null xs then x else last xs in+ if BS.null bs then Just a else Nothing _ -> Nothing parseKey :: [Word8] -> Maybe Key@@ -416,9 +465,9 @@ unsignData xs = do key <- parseKey $ take (fromIntegral (l - (8 + sb))) (drop (fromIntegral sb) xs'') return (fl,key) where- (l,xs') = xdrReadUInt xs- (sb,xs'') = xdrReadUInt (drop 4 xs')- fl = (decodeFragments $ drop (fromIntegral l + 4) xs')+ (l,xs') = xdrReadUInt xs+ (sb,xs'') = xdrReadUInt (drop 4 xs')+ fl = (decodeFragments $ drop (fromIntegral l + 4) xs') unsignFragments :: FragmentList -> Maybe FragmentList unsignFragments tfl | (xs:_) <- [xs | (n,FragmentData xs) <- tfl, n == f_securitySignature] = do@@ -450,21 +499,21 @@ getPrivateKey :: KeyCache -> String -> IO (Maybe (Key,EvpPkey)) getPrivateKey gc kn = modifyMVar (keyCache gc) f where f kc = case [x|x@(Key kn' _,_) <- kc, kn == kn'] of- (v:_) -> return (kc,Just v)- [] -> do- v <- ioMp getFromDisk- return ((maybeToList v ++ kc),v)+ (v:_) -> return (kc,Just v)+ [] -> do+ v <- ioMp getFromDisk+ return ((maybeToList v ++ kc),v) getFromDisk = do- let gd = galeDir gc- let p = (gd ++ "/auth/private/")- knames = [p ++ kn, p ++ kn ++ ".gpri"]- gn = (map (\fn -> (readRawFile fn >>= \c -> return (c,fn))) knames)- (key_c, fn) <- (first gn)- key <- parseKey key_c- rsa <- privkeyToRSA key- pkey <- pkeyNewRSA rsa- putLog LogNotice $ "Retrieved private key from disk: " ++ fn- return (key,pkey)+ let gd = galeDir gc+ let p = (gd ++ "/auth/private/")+ knames = [p ++ kn, p ++ kn ++ ".gpri"]+ gn = (map (\fn -> (readRawFile fn >>= \c -> return (c,fn))) knames)+ (key_c, fn) <- (first gn)+ key <- parseKey key_c+ rsa <- privkeyToRSA key+ pkey <- pkeyNewRSA rsa+ putLog LogNotice $ "Retrieved private key from disk: " ++ fn+ return (key,pkey) @@ -472,7 +521,7 @@ getPublicKey gc kn = modifyMVar (publicKeyCache gc) f where f keyCache | Just v <- lookupFM keyCache kn = return (keyCache, Just v) f keyCache = do- v <- ioM getFromDisk+ v <- ioM getFromDisk return $ case v of Nothing -> (keyCache, Nothing) Just v' -> (addToFM keyCache kn v', Just v')@@ -484,9 +533,9 @@ gn = (map (\fn -> (readRawFile fn >>= \c -> return (c,fn))) knames) putLog LogDebug $ "Looking for: " ++ show knames (key_c, fn) <- (first gn)- key <- parseKey key_c- rsa <- pubKeyToRSA key- pkey <- pkeyNewRSA rsa+ key <- parseKey key_c+ rsa <- pubKeyToRSA key+ pkey <- pkeyNewRSA rsa return (key,pkey) -}
Gale/Proto.hs view
@@ -56,14 +56,14 @@ xdrReadUInt :: [Word8] -> ( Word32,[Word8]) xdrReadUInt (b1:b2:b3:b4:bs) = (x,bs) where x = (fromIntegral b4) .|. (fromIntegral b3 `shiftL` 8) .|.- (fromIntegral b2 `shiftL` 16) .|. (fromIntegral b1 `shiftL` 24)+ (fromIntegral b2 `shiftL` 16) .|. (fromIntegral b1 `shiftL` 24) xdrReadUInt bs = error $ "xdrReadUInt " ++ show bs parseWord32 :: GenParser Word8 Word32 parseWord32 = do [b1,b2,b3,b4] <- parseSome 4 return $ (fromIntegral b4) .|. (fromIntegral b3 `shiftL` 8) .|.- (fromIntegral b2 `shiftL` 16) .|. (fromIntegral b1 `shiftL` 24)+ (fromIntegral b2 `shiftL` 16) .|. (fromIntegral b1 `shiftL` 24) parseLenData = parseWord32 >>= parseSome @@ -86,10 +86,10 @@ getGaleDir = do gd <- GenUtil.lookupEnv "GALE_DIR" case gd of- Just v -> return $ v ++ "/"- Nothing -> do- h <- getEnv "HOME"- return (h ++ "/.gale/")+ Just v -> return $ v ++ "/"+ Nothing -> do+ h <- getEnv "HOME"+ return (h ++ "/.gale/") decodeFrags :: Get FragmentList decodeFrags = df [] where
Gale/Puff.hs view
@@ -7,6 +7,7 @@ FragmentList, HasFragmentList(..), Category(Category),+ Dest(..), readPuffs, writePuffs, emptyPuff, categoryHead, categoryCell, catParseNew, catShowNew,@@ -46,8 +47,9 @@ ) where import Atom-import Data.Binary import qualified Control.Exception as E+import Data.Binary+import Data.Monoid import EIO import ErrorLog import GenUtil@@ -55,6 +57,7 @@ import Data.List import Data.Maybe(isJust) import PackedString+import Control.Concurrent.Async (Async) import System.IO import System.Time import RSA@@ -82,8 +85,21 @@ | FragmentInt !Int32 | FragmentNest FragmentList +data Dest = DestPublic | DestUnknown [String] | DestEncrypted [Key]+ deriving(Eq,Show)++instance Monoid Dest where+ mempty = DestEncrypted []+ DestUnknown a `mappend` DestUnknown b = DestUnknown (a ++ b)+ DestUnknown a `mappend` _ = DestUnknown a+ _ `mappend` DestUnknown a = DestUnknown a+ DestPublic `mappend` _ = DestPublic+ _ `mappend` DestPublic = DestPublic+ DestEncrypted a `mappend` DestEncrypted b = DestEncrypted (a ++ b)+ data Signature =- Unverifyable Key+ RequestingKey (Async Dest) Key BS.ByteString BS.ByteString+ | Unverifyable Key | Signed Key | Encrypted [String] @@ -148,15 +164,22 @@ getAuthor p = maybe "unknown" id (getSigner p) getSigner p = ss (signature p) where- ss (Signed (Key n _):_) = Just n- ss (Unverifyable (Key n _):_) = Just n- ss (_:sig) = ss sig- ss [] = Nothing+ ss (RequestingKey _ (Key n _) _ _:_) = Just n+ ss (Signed (Key n _):_) = Just n+ ss (Unverifyable (Key n _):_) = Just n+ ss (_:sig) = ss sig+ ss [] = Nothing -showSignature (Signed (Key n _)) = "Signed by " ++ n-showSignature (Unverifyable (Key n _)) = "Signed by " ++ n ++ " (unverified)"-showSignature (Encrypted xs) = "Encrypted to " ++ concatInter ", " xs+unverifiableStr :: Key -> String+unverifiableStr (Key n _) = "Signed by " ++ n ++ " (unverified)" +showSignature :: Signature -> String+showSignature s = case s of+ Signed (Key n _) -> "Signed by " ++ n+ RequestingKey _ k _ _ -> unverifiableStr k+ Unverifyable k -> unverifiableStr k+ Encrypted xs -> "Encrypted to " ++ concatInter ", " xs+ emptyPuff = Puff {cats = [], signature = [], fragments = []} fragmentData :: Monad m => Atom -> FragmentList -> m BS.ByteString@@ -288,9 +311,9 @@ instance Data.Binary.Binary Puff where put (Puff aa ab ac) = do- Data.Binary.put aa- Data.Binary.put ab- Data.Binary.put ac+ Data.Binary.put aa+ Data.Binary.put ab+ Data.Binary.put ac get = do aa <- get ab <- get@@ -299,68 +322,73 @@ instance Data.Binary.Binary Fragment where put (FragmentText aa) = do- Data.Binary.putWord8 0- Data.Binary.put aa+ Data.Binary.putWord8 0+ Data.Binary.put aa put (FragmentData ab) = do- Data.Binary.putWord8 1- Data.Binary.put ab+ Data.Binary.putWord8 1+ Data.Binary.put ab put (FragmentTime ac) = do- Data.Binary.putWord8 2- Data.Binary.put ac+ Data.Binary.putWord8 2+ Data.Binary.put ac put (FragmentInt ad) = do- Data.Binary.putWord8 3- Data.Binary.put ad+ Data.Binary.putWord8 3+ Data.Binary.put ad put (FragmentNest ae) = do- Data.Binary.putWord8 4- Data.Binary.put ae+ Data.Binary.putWord8 4+ Data.Binary.put ae get = do- h <- Data.Binary.getWord8- case h of- 0 -> do- aa <- Data.Binary.get- return (FragmentText aa)- 1 -> do- ab <- Data.Binary.get- return (FragmentData ab)- 2 -> do- ac <- Data.Binary.get- return (FragmentTime ac)- 3 -> do- ad <- Data.Binary.get- return (FragmentInt ad)- 4 -> do- ae <- Data.Binary.get- return (FragmentNest ae)- _ -> fail "invalid binary data found"+ h <- Data.Binary.getWord8+ case h of+ 0 -> do+ aa <- Data.Binary.get+ return (FragmentText aa)+ 1 -> do+ ab <- Data.Binary.get+ return (FragmentData ab)+ 2 -> do+ ac <- Data.Binary.get+ return (FragmentTime ac)+ 3 -> do+ ad <- Data.Binary.get+ return (FragmentInt ad)+ 4 -> do+ ae <- Data.Binary.get+ return (FragmentNest ae)+ _ -> fail "invalid binary data found" instance Data.Binary.Binary Signature where+ -- we do not differentiate between signatures that were in mid-flight fetch+ -- and signatures that could not be verified+ put (RequestingKey _ aa _ _) = do+ Data.Binary.putWord8 0+ Data.Binary.put aa put (Unverifyable aa) = do- Data.Binary.putWord8 0- Data.Binary.put aa+ Data.Binary.putWord8 0+ Data.Binary.put aa put (Signed ab) = do- Data.Binary.putWord8 1- Data.Binary.put ab+ Data.Binary.putWord8 1+ Data.Binary.put ab put (Encrypted ac) = do- Data.Binary.putWord8 2- Data.Binary.put ac+ Data.Binary.putWord8 2+ Data.Binary.put ac get = do- h <- Data.Binary.getWord8- case h of- 0 -> do- aa <- Data.Binary.get- return (Unverifyable aa)- 1 -> do- ab <- Data.Binary.get- return (Signed ab)- 2 -> do- ac <- Data.Binary.get- return (Encrypted ac)- _ -> fail "invalid binary data found"+ h <- Data.Binary.getWord8+ case h of+ 0 -> do+ aa <- Data.Binary.get+ return (Unverifyable aa)+ 1 -> do+ ab <- Data.Binary.get+ return (Signed ab)+ 2 -> do+ ac <- Data.Binary.get+ return (Encrypted ac)+ _ -> fail "invalid binary data found" instance Data.Binary.Binary Key where put (Key aa ab) = do- Data.Binary.put aa- Data.Binary.put ab+ Data.Binary.put aa+ Data.Binary.put ab get = do aa <- get ab <- get
GenUtil.hs view
@@ -121,8 +121,8 @@ import Control.Monad import qualified System.IO as IO import qualified System.IO.Error as IO-import qualified System.Exit as System -import qualified System.Environment as System +import qualified System.Exit as System+import qualified System.Environment as System import System.Random(StdGen, newStdGen, Random(randomR)) import System.Time import System.CPUTime
GinsuConfig.hs view
@@ -54,20 +54,20 @@ mapM_ putStrLn $ buildTableLL [- ( "GALE_DIR ", galeDir),- ( "GALE_DOMAIN ", galeDomain),- ( "GALE_ID ", gid),- ( "GALE_PROXY ", simpleQuote gp),- ( "GALE_SUBSCRIBE ", unwords (snub galeSubscribe)) ]+ ( "GALE_DIR ", galeDir),+ ( "GALE_DOMAIN ", galeDomain),+ ( "GALE_ID ", gid),+ ( "GALE_PROXY ", simpleQuote gp),+ ( "GALE_SUBSCRIBE ", unwords (snub galeSubscribe)) ] when (galeAliases /= []) $ putStrLn $ "GALE_ALIASES \n" ++- unlines ( map (\ (l,cat) -> " " ++ l ++ " -> " ++ show cat) galeAliases)+ unlines ( map (\ (l,cat) -> " " ++ l ++ " -> " ++ show cat) galeAliases) let p = (galeDir ++ "/auth/private/")- knames = [p ++ gid, p ++ gid ++ ".gpri"]+ knames = [p ++ gid, p ++ gid ++ ".gpri"] gn <- (mapM (\fn -> (doesFileExist fn >>= \b -> if b then return (Just fn) else return Nothing)) knames) case msum gn of- Just fn -> putStrLn $ "Private key found in: " ++ fn- Nothing -> putStrLn $ "Private key for '" ++ gid ++ "' not found in " ++ p+ Just fn -> putStrLn $ "Private key found in: " ++ fn+ Nothing -> putStrLn $ "Private key for '" ++ gid ++ "' not found in " ++ p putStrLn "" --putStrLn showKeyInfo --kt <- buildKeyTable@@ -87,12 +87,12 @@ getGaleProxy = do gps <- configLookup "GALE_PROXY" case gps of- Nothing -> do- v <- configLookup "GALE_DOMAIN"+ Nothing -> do+ v <- configLookup "GALE_DOMAIN" case v of Just v -> return $ hostStrings v Nothing -> return []- (Just x) -> return (words x)+ (Just x) -> return (words x) getGaleId :: IO String@@ -118,10 +118,10 @@ fs <- handle (\(_ :: IOException) -> return []) $ getDirectoryContents v --putLog LogDebug $ "aliases/ " ++ show fs let f fn = do- --fc <- first [readFile (v ++ fn), readSymbolicLink (v ++ fn)]+ --fc <- first [readFile (v ++ fn), readSymbolicLink (v ++ fn)] fc <- readAlias (v ++ fn) --putLog LogDebug $ "readAlias " ++ (v ++ fn) ++ " " ++ fc- return (fn, catParseNew fc)+ return (fn, catParseNew fc) tryMapM f fs
Help.hs view
@@ -62,12 +62,12 @@ filterExamples = "Filter Examples:\n" ++ indentLines 4 (unlines es) where es = [- "(~a:john@ugcs.caltech.edu)\n all puffs by john@ugcs",- "(~c:pub.tv.buffy ~a:jtr@ofb.net)\n puffs from jtr and to pub.tv.buffy",- "(/ginsu ; ~c:pub.gale.ginsu)\n puffs containing the word ginsu or directed to pub.comp.ginsu",- "(!~k:spoil)\n no spoilers",- "(~c:pub.tv.buffy !~c:pub.meow)\n puffs to buffy which are not about cats"- ]+ "(~a:john@ugcs.caltech.edu)\n all puffs by john@ugcs",+ "(~c:pub.tv.buffy ~a:jtr@ofb.net)\n puffs from jtr and to pub.tv.buffy",+ "(/ginsu ; ~c:pub.gale.ginsu)\n puffs containing the word ginsu or directed to pub.comp.ginsu",+ "(!~k:spoil)\n no spoilers",+ "(~c:pub.tv.buffy !~c:pub.meow)\n puffs to buffy which are not about cats"+ ] {-
KeyName.hs view
@@ -24,8 +24,8 @@ --stringToKeys ('<':c:'-':x:'>':cs) | c `elem` "cC" = KeyChar (ord (toLower x) - 0x40) : stringToKeys cs stringToKeys ('<':cs) = let (n,r) = span (/= '>') cs in case lookup ((map toLower $ filter (not . isSpace) n)) ftl of- Just k -> k- Nothing -> KeyUnknown 0+ Just k -> k+ Nothing -> KeyUnknown 0 : stringToKeys (drop 1 r) stringToKeys (c:cs) = KeyChar c : stringToKeys cs @@ -79,7 +79,7 @@ kg :: [[Key]] kg = transitiveGroup $ map (snub . map snd) (groupBy (\(x,_) (y,_) -> x == y)- (sort ftl))+ (sort ftl)) lkg :: Key -> [Key] lkg k = case lookup k kgm of
Main.hs view
@@ -75,19 +75,19 @@ withErrorMessage bugMsg $ do logname <- case envErrorLog flags of- Just x -> return x- Nothing -> galeFile "ginsu.errorlog"+ Just x -> return x+ Nothing -> galeFile "ginsu.errorlog" withErrorLog logname $ withStartEndEntrys "Ginsu" $ do case (envVerbose flags) of- 1 -> do- setLogLevel LogInfo- putLog LogNotice $ "Verbosity level: Info"- n | n > 1 -> do- setLogLevel LogDebug- putLog LogNotice $ "Verbosity level: Debug"- _ -> return ()+ 1 -> do+ setLogLevel LogInfo+ putLog LogNotice $ "Verbosity level: Info"+ n | n > 1 -> do+ setLogLevel LogDebug+ putLog LogNotice $ "Verbosity level: Debug"+ _ -> return () cs <- configLookup "CHARSET" @@ -119,7 +119,7 @@ putLog LogInfo $ "GALE_ID " ++ gid putLog LogInfo $ "GALE_PROXY " ++ simpleQuote gp putLog LogInfo $ "GALE_ALIASES \n" ++- unlines ( map (\(l,cat) -> " " ++ l ++ " -> " ++ show cat) galeAliases)+ unlines ( map (\(l,cat) -> " " ++ l ++ " -> " ++ show cat) galeAliases) Control.Exception.bracket_ initCurses endWin $ do@@ -136,8 +136,8 @@ Posix.installHandler Posix.sigINT Posix.Ignore Nothing Posix.installHandler Posix.sigPIPE Posix.Ignore Nothing case (b,cursesSigWinch) of- (False,Just s) -> Posix.installHandler s (Posix.Catch (resizeRenderContext redraw_r (writeChan ic (MainEventKey KeyResize)))) Nothing >> return ()- _ -> return ()+ (False,Just s) -> Posix.installHandler s (Posix.Catch (resizeRenderContext redraw_r (writeChan ic (MainEventKey KeyResize)))) Nothing >> return ()+ _ -> return () gs <- fmap (concat . map words) $ configLookupList "GALE_SUBSCRIBE" gps <- getGaleProxy@@ -154,6 +154,7 @@ galeAddCategories gc $ map catParseNew (snub $ c ++ nc) Category (name,domain) <- fmap catParseNew getGaleId galeAddCategories gc $ [Category ("_gale.rr." ++ name ,domain)]+ galeAddCategories gc $ [Category ("_gale.query." ++ name, domain)] doRender widgetEmpty pl <- forkIO $ puffLoop ic gc gl <- forkIO $ getchLoop ic@@ -182,9 +183,9 @@ n' <- readVal pcount_r if n' /= n then do- ps <- liftM (map snd) $ readVal ps_r- writePufflog ps- pufflogLoop ps_r pcount_r n'+ ps <- liftM (map snd) $ readVal ps_r+ writePufflog ps+ pufflogLoop ps_r pcount_r n' else pufflogLoop ps_r pcount_r n writePufflog ps = do@@ -208,9 +209,9 @@ as <- getGaleAliases gd <- getGaleDomain let ec x@(Category (c,"")) = de $ head $ [Category (tc ++ drop (length f) c,td) | (f,Category (tc,td)) <- as, f `isPrefixOf` c] ++ [x]- ec x = x- de (Category (c,"")) = Category (c,gd)- de x = x+ ec x = x+ de (Category (c,"")) = Category (c,gd)+ de x = x return $ map ec cats {-@@ -268,15 +269,15 @@ u <- newUnique gn <- configLookup "GALE_NAME" n <- case gn of- Just n -> return ((f_messageSender,FragmentText (packString n)):)- Nothing -> return id+ Just n -> return ((f_messageSender,FragmentText (packString n)):)+ Nothing -> return id let mid = sha1 . LBS.pack $ map (fromIntegral . ord) (show t ++ " " ++ idText ++ " " ++ show (hashUnique u)) let sig = [Signed (Key gi [])] let ef = n [- (f_messageId, FragmentText $ packString $ bsToHex mid),- (fromString "id/class",FragmentText $ packString (package ++ "/" ++ version) ),- (fromString "id/instance", FragmentText $ packString idText),- (f_idTime,FragmentTime t)]+ (f_messageId, FragmentText $ packString $ bsToHex mid),+ (fromString "id/class",FragmentText $ packString (package ++ "/" ++ version) ),+ (fromString "id/instance", FragmentText $ packString idText),+ (f_idTime,FragmentTime t)] return emptyPuff {fragments = ef, signature = sig} @@ -371,7 +372,7 @@ icmain <- newChan let fsw = newSVarWidget filter_r $ \fs ->- widgetHorizontalBox False (intersperse (NoExpand, widgetText " ") $ map (\w -> (NoExpand,widgetAttr [AttrReverse] (widgetText w))) (map showFilter fs))+ widgetHorizontalBox False (intersperse (NoExpand, widgetText " ") $ map (\w -> (NoExpand,widgetAttr [AttrReverse] (widgetText w))) (map showFilter fs)) selPuff <- newCacheIO $ do ps <- readVal psr@@ -406,9 +407,9 @@ Right _ -> id Left s -> \w -> widgetVerticalBox False [ne w, (NoExpand,widgetAttr [AttrReverse] (widgetText $ "*** " ++ s ++ " ***"))] return $ f $ widgetHorizontalBox False [ne m, (Expand, widgetEmpty), wt "Workspace:", ne ws ,wt " ", ne s, wt " (", ne nf , wt "/", ne pc , wt ") " ]- let keyError s k = messageBox rc fw (s ++ ": " ++ keysToString [k] ++ " -- " ++ helpText) >> return ()+ let keyError s k = messageBox rc fw (s ++ ": " ++ keysToString [k] ++ " -- " ++ helpText) >> return () setMessage m = messageBox rc fw m >> return ()- scrollPuffs x = mapVal yor (+ x)+ scrollPuffs x = mapVal yor (+ x) autoSaveMark = do n <- readVal (gsWorkspace gs) s <- readVal selected_r@@ -423,25 +424,25 @@ maybe (return ()) (writeVal selected_r) s select_perhaps select_next center_puff- filter_thread = do- p <- selPuff- case p of- Just (Puff {cats = [c]}) -> modifyFilter (BoolJust (FilterCategory c):)- Just (Puff {cats = cs}) -> modifyFilter (or (map (BoolJust . FilterCategory) cs):)- _ -> return ()+ filter_thread = do+ p <- selPuff+ case p of+ Just (Puff {cats = [c]}) -> modifyFilter (BoolJust (FilterCategory c):)+ Just (Puff {cats = cs}) -> modifyFilter (or (map (BoolJust . FilterCategory) cs):)+ _ -> return () - addPuff p = do+ addPuff p = do let author = getAuthor p Category (name,domain) <- fmap catParseNew getGaleId- case getFragmentString p (f_noticePresence') of- Nothing -> return ()- Just pn -> do- let np@(a',(b',_)) = (author, (maybe "unknown" unpackPS (getFragmentString p (fromString "id/instance")), unpackPS pn))- mapVal presence_r (\xs -> (np:[x | x@(a,(b,_)) <- xs, a /= a' || b /= b']))- case getFragmentTime p (fromString "status.idle") of- Nothing -> return ()+ case getFragmentString p (f_noticePresence') of+ Nothing -> return ()+ Just pn -> do+ let np@(a',(b',_)) = (author, (maybe "unknown" unpackPS (getFragmentString p (fromString "id/instance")), unpackPS pn))+ mapVal presence_r (\xs -> (np:[x | x@(a,(b,_)) <- xs, a /= a' || b /= b']))+ case getFragmentTime p (fromString "status.idle") of+ Nothing -> return () Just pn | pn == epoch -> Hash.delete idleHash author >> getClockTime >>= Hash.insert idleHash author- Just pn -> do+ Just pn -> do mt <- Hash.lookup idleHash author Hash.delete idleHash author Hash.insert idleHash author $ fromJust $ max mt (Just pn)@@ -453,136 +454,136 @@ _ -> return () - case getFragmentString p (f_questionReceipt) of- Nothing -> return ()- Just _ -> buildReciept p >>= \p -> forkIO (galeSendPuff gc p) >> return ()- case fmap unpackPS $ getFragmentString p f_messageBody of- Nothing -> return ()- Just n -> when (not $ (all isSpace n) && (all (("_gale" `isPrefixOf`) . categoryHead) (cats p))) $ do+ case getFragmentString p (f_questionReceipt) of+ Nothing -> return ()+ Just _ -> buildReciept p >>= \p -> forkIO (galeSendPuff gc p) >> return ()+ case fmap unpackPS $ getFragmentString p f_messageBody of+ Nothing -> return ()+ Just n -> when (not $ (all isSpace n) && (all (("_gale" `isPrefixOf`) . categoryHead) (cats p))) $ do mt <- Hash.lookup idleHash author pn <- getClockTime Hash.insert idleHash author $ fromJust $ max mt (Just pn)- v <- configLookupList "BEEP"- let f = or (rights (map parseFilter v))- when (filterAp f p) Curses.beep- n <- readVal next_r- mapVal next_r (+1)- mapVal pcount_r (+1)- mapVal psr (\ps -> ((n,p):ps))+ v <- configLookupList "BEEP"+ let f = or (rights (map parseFilter v))+ when (filterAp f p) Curses.beep+ n <- readVal next_r+ mapVal next_r (+1)+ mapVal pcount_r (+1)+ mapVal psr (\ps -> ((n,p):ps)) sbsize <- fmap (read . fromJust) $ configLookup "SCROLLBACK_SIZE"- case sbsize of- 0 -> return ()+ case sbsize of+ 0 -> return () _ -> do let keep = min n sbsize mapVal psr (\ps -> zip [keep, (keep - 1) .. 1] (snds $ take keep ps)) mapVal selected_r (\s -> s - (n - keep)) mapVal next_r (\s -> s - (n - keep))- select_perhaps select_next- --touchRenderContext rc- composePuff :: IO () -> [Category] -> [PackedString] -> IO ()- composePuff done cs kwds = do- p <- puffTemplate- editPuff (p {cats = cs, fragments = fragments p ++ [ (f_messageKeyword,FragmentText k) | k <- kwds]}) ic done- getPresenceFrags = do- mp <- readVal myPresence- (TOD ct _) <- getClockTime- uaT@(TOD uat _) <- readVal userActionTime- (it,is,notIdle) <- return $ case ct - uat of- n | n < idleThreshold -> (epoch," (not idle)",True)- n -> (uaT," (" ++ (showDuration n) ++ " idle)",False)- return ([- (f_noticePresence',FragmentText (packString (mp ++ is))),- (fromString "status.presence", FragmentText $ packString mp),- (fromString "status.idle", FragmentTime it)],notIdle)- buildReciept p = do- np <- puffTemplate- r <- getFragmentString p (fromString "question.receipt")- gid <- getGaleId- let rid = maybe [] (\x -> [(fromString "receipt.id",FragmentText x)]) $ getFragmentString p (f_messageId)- (pf,_) <- getPresenceFrags- return $ np { cats = [catParseNew (unpackPS r)], fragments = fragments np ++ pf ++ rid ++ [(fromString "answer.receipt",FragmentText $ packString gid)]}- presenceLoop = do- let loopIsIdle ct = do+ select_perhaps select_next+ --touchRenderContext rc+ composePuff :: IO () -> [Category] -> [PackedString] -> IO ()+ composePuff done cs kwds = do+ p <- puffTemplate+ editPuff (p {cats = cs, fragments = fragments p ++ [ (f_messageKeyword,FragmentText k) | k <- kwds]}) ic done+ getPresenceFrags = do+ mp <- readVal myPresence+ (TOD ct _) <- getClockTime+ uaT@(TOD uat _) <- readVal userActionTime+ (it,is,notIdle) <- return $ case ct - uat of+ n | n < idleThreshold -> (epoch," (not idle)",True)+ n -> (uaT," (" ++ (showDuration n) ++ " idle)",False)+ return ([+ (f_noticePresence',FragmentText (packString (mp ++ is))),+ (fromString "status.presence", FragmentText $ packString mp),+ (fromString "status.idle", FragmentTime it)],notIdle)+ buildReciept p = do+ np <- puffTemplate+ r <- getFragmentString p (fromString "question.receipt")+ gid <- getGaleId+ let rid = maybe [] (\x -> [(fromString "receipt.id",FragmentText x)]) $ getFragmentString p (f_messageId)+ (pf,_) <- getPresenceFrags+ return $ np { cats = [catParseNew (unpackPS r)], fragments = fragments np ++ pf ++ rid ++ [(fromString "answer.receipt",FragmentText $ packString gid)]}+ presenceLoop = do+ let loopIsIdle ct = do ct' <- waitJVarEq userActionTime ct notIdle <- sendPresence True if notIdle then loopNotIdle else loopIsIdle ct'- loopNotIdle = do- notIdle <- sendPresence False- threadDelay $ (fromIntegral idleThreshold) * 1000000- if notIdle then loopNotIdle else readVal userActionTime >>= loopIsIdle- sendPresence True- loopNotIdle- sendPresence sendIfNotIdle = do+ loopNotIdle = do+ notIdle <- sendPresence False+ threadDelay $ (fromIntegral idleThreshold) * 1000000+ if notIdle then loopNotIdle else readVal userActionTime >>= loopIsIdle+ sendPresence True+ loopNotIdle+ sendPresence sendIfNotIdle = do notifyCategory <- getMyNotifyCategory- (pf,notIdle) <- getPresenceFrags- when (sendIfNotIdle || not notIdle) $ do- p <- puffTemplate- galeSendPuff gc $ p {cats = [notifyCategory], fragments = fragments p ++ pf}- return notIdle- gonePresencePuff = do+ (pf,notIdle) <- getPresenceFrags+ when (sendIfNotIdle || not notIdle) $ do+ p <- puffTemplate+ galeSendPuff gc $ p {cats = [notifyCategory], fragments = fragments p ++ pf}+ return notIdle+ gonePresencePuff = do notifyCategory <- getMyNotifyCategory- p <- puffTemplate- let ef = [(f_noticePresence' ,FragmentText (toPackedString f_outGone)), (f_noticePresence, FragmentText (toPackedString f_outGone))]- return $ p {cats = [notifyCategory], fragments = fragments p ++ ef }- modifyFilter f = do- mapVal filter_r f- select_perhaps select_next >> select_perhaps select_prev- center_puff- center_puff = do- (ys,_) <- scrSize- selected <- readVal selected_r- ps <- liftM reverse getFilteredPuffs- let f t (((n,_),h):_) | n == selected = (t,t+h)- f t ((_,h):rest) = f (t + h) rest- f _ [] = (1000000,0)- let (mn,mx) = (f 0) ps- mapVal yor (min mn)- sh <- statusHeight- mapVal yor (max (mx - (ys - sh) ))- is_at_end = do- (ys,_) <- scrSize- bs <- buf_size- sh <- statusHeight- fmap ((max (bs - (ys - sh)) 0) ==) $ readVal yor+ p <- puffTemplate+ let ef = [(f_noticePresence' ,FragmentText (toPackedString f_outGone)), (f_noticePresence, FragmentText (toPackedString f_outGone))]+ return $ p {cats = [notifyCategory], fragments = fragments p ++ ef }+ modifyFilter f = do+ mapVal filter_r f+ select_perhaps select_next >> select_perhaps select_prev+ center_puff+ center_puff = do+ (ys,_) <- scrSize+ selected <- readVal selected_r+ ps <- liftM reverse getFilteredPuffs+ let f t (((n,_),h):_) | n == selected = (t,t+h)+ f t ((_,h):rest) = f (t + h) rest+ f _ [] = (1000000,0)+ let (mn,mx) = (f 0) ps+ mapVal yor (min mn)+ sh <- statusHeight+ mapVal yor (max (mx - (ys - sh) ))+ is_at_end = do+ (ys,_) <- scrSize+ bs <- buf_size+ sh <- statusHeight+ fmap ((max (bs - (ys - sh)) 0) ==) $ readVal yor scroll_end = do- (ys,_) <- scrSize- bs <- buf_size- sh <- statusHeight- writeVal yor (max (bs - (ys - sh)) 0)- doRedraw _ (xs,ys) = do- bs <- buf_size- sh <- statusHeight- mapVal yor (min (max 0 (bs - (ys - sh))))- selected <- readVal selected_r- ps <- getFilteredPuffs- yo <- readVal yor- isRot13 <- readVal rot13_r- let rp _ [] = return ()- rp y (((i,p),n):rest) = do- when ((0,ys) `overlaps` (y - yo, y - yo + n)) $ renderPuff p xs stdScr (y - yo) (xs,ys) (i == selected) (if isRot13 then rot13 else id)- rp (y + n) rest- attemptIO (rp 0 (reverse ps))- select_perhaps a = do- ps <- getFilteredPuffs- n <- readVal selected_r- unless (maybe False (const True) $ lookup n (fsts ps)) a- select_prev = do- ps <- liftM fsts getFilteredPuffs- let f sel ((n,_):_) | n < sel = n- f sel (_:ps) = f sel ps- f sel [] = sel- mapVal selected_r (\s ->(f s ps))- select_next = do- ps <- liftM fsts getFilteredPuffs- let f sel _ ((n,_):ps) | n > sel = f sel n ps- f sel bg ((n,_):ps) | n > sel = f sel bg ps- f _ bg _ = bg- mapVal selected_r (\s ->(f s s ps))+ (ys,_) <- scrSize+ bs <- buf_size+ sh <- statusHeight+ writeVal yor (max (bs - (ys - sh)) 0)+ doRedraw _ (xs,ys) = do+ bs <- buf_size+ sh <- statusHeight+ mapVal yor (min (max 0 (bs - (ys - sh))))+ selected <- readVal selected_r+ ps <- getFilteredPuffs+ yo <- readVal yor+ isRot13 <- readVal rot13_r+ let rp _ [] = return ()+ rp y (((i,p),n):rest) = do+ when ((0,ys) `overlaps` (y - yo, y - yo + n)) $ renderPuff p xs stdScr (y - yo) (xs,ys) (i == selected) (if isRot13 then rot13 else id)+ rp (y + n) rest+ attemptIO (rp 0 (reverse ps))+ select_perhaps a = do+ ps <- getFilteredPuffs+ n <- readVal selected_r+ unless (maybe False (const True) $ lookup n (fsts ps)) a+ select_prev = do+ ps <- liftM fsts getFilteredPuffs+ let f sel ((n,_):_) | n < sel = n+ f sel (_:ps) = f sel ps+ f sel [] = sel+ mapVal selected_r (\s ->(f s ps))+ select_next = do+ ps <- liftM fsts getFilteredPuffs+ let f sel _ ((n,_):ps) | n > sel = f sel n ps+ f sel bg ((n,_):ps) | n > sel = f sel bg ps+ f _ bg _ = bg+ mapVal selected_r (\s ->(f s s ps)) fw = widgetVerticalBox False [(ExpandFill, mwidget), (NoExpand, widgetAttr [AttrBold] sb), (NoExpand, fsw)]- mwidget = widgetEmpty { render = rnd, processKey = pk}- rnd canvas = doRedraw (origin canvas) (bounds canvas)- continue = return True+ mwidget = widgetEmpty { render = rnd, processKey = pk}+ rnd canvas = doRedraw (origin canvas) (bounds canvas)+ continue = return True keyTable' = (map (\(a,b) -> (a, perform_action b)) keyTable) pk x = case lookup x keyTable' of Nothing -> case x of@@ -762,53 +763,53 @@ pcw <- puffConfirm gc (setRenderWidget rc fw) p ic setRenderWidget rc pcw continue- "redraw_screen" -> attemptIO (touchWin stdScr) >> resizeRenderContext rc (return ()) >> continue- "show_help_screen" -> setRenderWidget rc (keyCatcherWidget (\_ -> setRenderWidget rc fw >> return True) hw) >> continue- "show_status_screen" -> setRenderWidget rc (keyCatcherWidget (\_ -> setRenderWidget rc fw >> return True) statusWidget) >> continue- "show_presence_status" -> setRenderWidget rc (keyCatcherWidget (\_ -> setRenderWidget rc fw >> return True) presenceWidget) >> continue+ "redraw_screen" -> attemptIO (touchWin stdScr) >> resizeRenderContext rc (return ()) >> continue+ "show_help_screen" -> setRenderWidget rc (keyCatcherWidget (\_ -> setRenderWidget rc fw >> return True) hw) >> continue+ "show_status_screen" -> setRenderWidget rc (keyCatcherWidget (\_ -> setRenderWidget rc fw >> return True) statusWidget) >> continue+ "show_presence_status" -> setRenderWidget rc (keyCatcherWidget (\_ -> setRenderWidget rc fw >> return True) presenceWidget) >> continue act -> setMessage ("Unknown action: " ++ act ++ " -- " ++ helpText) >> continue- puffDetailsWidget p = do- (_,xs) <- scrSize- let pv = newSVarWidget presence_r (presenceViewUser (getAuthor p))+ puffDetailsWidget p = do+ (_,xs) <- scrSize+ let pv = newSVarWidget presence_r (presenceViewUser (getAuthor p)) wr <- case fmap unpackPS (getFragmentString p (f_messageId)) of Nothing -> return "" Just mid -> Hash.lookup puffRRHash mid >>= \ml -> case ml of Nothing -> return "" Just ml -> return $ "\nReceieved by:\n" ++ unlines (snub ml)- v <- widgetScroll (widgetVerticalBox False [(NoExpand,widgetText $ chunkText (xs - 1) ((showPuff p) ++ wr)), (NoExpand, widgetText "\n\n\n"), (NoExpand, pv)])- return v- justGetKey = readChan ic >>= \v -> case v of- (MainEventPuff p) -> addPuff p >> justGetKey- (MainEventKey k) -> do- getClockTime >>= writeVal userActionTime- return $ keyCanon k- _ -> writeChan icmain v >> justGetKey- nextKey = do- ce <- isEmptyChan ic- when ce $ tryDrawRenderContext rc- cemain <- isEmptyChan icmain- v <- if cemain then readChan ic else readChan icmain- case v of- (MainEventPuff p) -> do+ v <- widgetScroll (widgetVerticalBox False [(NoExpand,widgetText $ chunkText (xs - 1) ((showPuff p) ++ wr)), (NoExpand, widgetText "\n\n\n"), (NoExpand, pv)])+ return v+ justGetKey = readChan ic >>= \v -> case v of+ (MainEventPuff p) -> addPuff p >> justGetKey+ (MainEventKey k) -> do+ getClockTime >>= writeVal userActionTime+ return $ keyCanon k+ _ -> writeChan icmain v >> justGetKey+ nextKey = do+ ce <- isEmptyChan ic+ when ce $ tryDrawRenderContext rc+ cemain <- isEmptyChan icmain+ v <- if cemain then readChan ic else readChan icmain+ case v of+ (MainEventPuff p) -> do v <- is_at_end- addPuff p+ addPuff p when v scroll_end- s <- configLookupElse "ON_INCOMING_PUFF" ""- mapM_ (processKey mwidget) (stringToKeys s)- nextKey- (MainEventKey KeyResize) -> nextKey- (MainEventKey k) -> do- getClockTime >>= writeVal userActionTime- b <- keyRenderContext rc $ keyCanon k- if b then nextKey else return ()- (MainEventComposed ep done) -> do- case ep of- Nothing -> setMessage "Puff cancelled"- Just p -> do- pcw <- puffConfirm gc done p ic- setRenderWidget rc pcw- writeVal editing_r False- nextKey+ s <- configLookupElse "ON_INCOMING_PUFF" ""+ mapM_ (processKey mwidget) (stringToKeys s)+ nextKey+ (MainEventKey KeyResize) -> nextKey+ (MainEventKey k) -> do+ getClockTime >>= writeVal userActionTime+ b <- keyRenderContext rc $ keyCanon k+ if b then nextKey else return ()+ (MainEventComposed ep done) -> do+ case ep of+ Nothing -> setMessage "Puff cancelled"+ Just p -> do+ pcw <- puffConfirm gc done p ic+ setRenderWidget rc pcw+ writeVal editing_r False+ nextKey np <- configLookupBool "NO_PRESENCE_NOTIFY" done <- if np then return (return ()) else do@@ -855,13 +856,13 @@ c = fromIntegral $ hashPS (packString (x ++ "@" ++ y)) doit = do let ac = fromIntegral $ hashPS $ packString (getAuthor p)- when (y >= 0 && y < ys) $ do- wmove w y 0- when selected $ standout >> return ()- sequence (intersperse (space w) $ map (addCat w) cats)- when selected $ standend >> return ()- space w >> space w- when selected $ standout >> return ()+ when (y >= 0 && y < ys) $ do+ wmove w y 0+ when selected $ standout >> return ()+ sequence (intersperse (space w) $ map (addCat w) cats)+ when selected $ standend >> return ()+ space w >> space w+ when selected $ standout >> return () waddstr w (unwords (map (('/':) . unpackPS) kwds)) Just fmt <- configLookup "PUFF_DATE_FORMAT" st <- fmap (formatCalendarTime defaultTimeLocale fmt) $ toCalendarTime time@@ -1084,28 +1085,28 @@ where l n v = min (max n 0) (length v) cr cloc v = pc cloc v >> ic >>= \x -> case x of- (KeyChar '\n') -> return $ return (reverse v)- (KeyChar '\r') -> return $ return (reverse v)- (KeyEnter) -> return $ return (reverse v)- (KeyChar '\b') -> let z = (let (a,b) = splitAt (length v - cloc) v in a ++ drop 1 b) in cr (l (cloc - 1) z) z- (KeyBackspace) -> let z = (let (a,b) = splitAt (length v - cloc) v in a ++ drop 1 b) in cr (l (cloc - 1) z) z+ (KeyChar '\n') -> return $ return (reverse v)+ (KeyChar '\r') -> return $ return (reverse v)+ (KeyEnter) -> return $ return (reverse v)+ (KeyChar '\b') -> let z = (let (a,b) = splitAt (length v - cloc) v in a ++ drop 1 b) in cr (l (cloc - 1) z) z+ (KeyBackspace) -> let z = (let (a,b) = splitAt (length v - cloc) v in a ++ drop 1 b) in cr (l (cloc - 1) z) z (KeyHome) -> cr 0 v (KeyEnd) -> cr (length v) v (KeyLeft) -> cr (l (cloc - 1) v) v (KeyRight) -> cr (l (cloc + 1) v) v (KeyChar '\x0B') -> cr cloc (drop (length v - cloc) v) (KeyChar '\BEL') -> return (fail "")- (KeyChar c) -> cr (cloc + 1) (let (a,b) = splitAt (length v - cloc) v in a ++ [c] ++ b)+ (KeyChar c) -> cr (cloc + 1) (let (a,b) = splitAt (length v - cloc) v in a ++ [c] ++ b) - _ -> return (fail "unknown key")+ _ -> return (fail "unknown key") pc cloc v = do- wmove win yloc 0- wClrToEol win- wAttrOn win attrBold- waddstr win prompt- wAttrOff win attrBold- waddstr win (reverse v)- wmove win yloc (cloc + length prompt)- refresh+ wmove win yloc 0+ wClrToEol win+ wAttrOn win attrBold+ waddstr win prompt+ wAttrOff win attrBold+ waddstr win (reverse v)+ wmove win yloc (cloc + length prompt)+ refresh
Options.hs view
@@ -68,16 +68,16 @@ ginsuOpts = do args <- getArgs r@(env,_) <- case (getOpt Permute (options ++ privateOptions) args) of- (as,n,[]) -> return (foldr ($) env as ,n)- (_,_,errs) -> putErrDie (concat errs ++ usage)+ (as,n,[]) -> return (foldr ($) env as ,n)+ (_,_,errs) -> putErrDie (concat errs ++ usage) case (envVerbose env) of- 1 -> do- setLogLevel LogInfo- putLog LogNotice $ "Verbosity Level: Info"- n | n > 1 -> do- setLogLevel LogDebug- putLog LogNotice $ "Verbosity Level: Debug"- _ -> return ()+ 1 -> do+ setLogLevel LogInfo+ putLog LogNotice $ "Verbosity Level: Info"+ n | n > 1 -> do+ setLogLevel LogDebug+ putLog LogNotice $ "Verbosity Level: Debug"+ _ -> return () envAction env return r
PackedString.hs view
@@ -20,29 +20,29 @@ -- changed to a trivial wrapper for Data.ByteString.UTF8 by Dylan Simon module PackedString (- -- * The @PackedString@ type+ -- * The @PackedString@ type PackedString, -- abstract, instances: Eq, Ord, Show, Typeable -- * Converting to and from @PackedString@s- packString, -- :: String -> PackedString- unpackPS, -- :: PackedString -> String+ packString, -- :: String -> PackedString+ unpackPS, -- :: PackedString -> String showsPS, -- toString, -- lengthPS, -- utfLengthPS, - joinPS, -- :: PackedString -> [PackedString] -> PackedString- -- * List-like manipulation functions- nilPS, -- :: PackedString- consPS, -- :: Char -> PackedString -> PackedString- nullPS, -- :: PackedString -> Bool- appendPS, -- :: PackedString -> PackedString -> PackedString+ joinPS, -- :: PackedString -> [PackedString] -> PackedString+ -- * List-like manipulation functions+ nilPS, -- :: PackedString+ consPS, -- :: Char -> PackedString -> PackedString+ nullPS, -- :: PackedString -> Bool+ appendPS, -- :: PackedString -> PackedString -> PackedString -- foldrPS, hashPS, -- filterPS, -- foldlPS, -- headPS,- concatPS -- :: [PackedString] -> PackedString+ concatPS -- :: [PackedString] -> PackedString
RSA.hsc view
@@ -7,7 +7,8 @@ createPkey, sha1, bsToHex,- RSAElems(..)+ RSAElems(..),+ verifyAll ) where #include "my_rsa.h"@@ -50,7 +51,7 @@ returnData :: Int -> (Ptr CUChar -> Ptr CInt -> IO z) -> IO BS.ByteString returnData sz f = do- alloca $ \bp ->+ alloca $ \bp -> allocaArray sz $ \m -> do f m bp s <- peek bp@@ -103,6 +104,9 @@ foreign import ccall unsafe "openssl/evp.h EVP_des_ede3_cbc" evpDesEde3Cbc :: IO (Ptr EVP_CIPHER) foreign import ccall unsafe "openssl/evp.h EVP_md5" evpMD5 :: IO (Ptr EVP_MD) +foreign import ccall unsafe "openssl/evp.h EVP_DigestInit" evpDigestInit :: Ptr EVP_MD_CTX -> Ptr EVP_MD -> IO CInt+foreign import ccall unsafe "openssl/evp.h EVP_DigestUpdate" evpDigestUpdate :: Ptr EVP_MD_CTX -> Ptr a -> CInt -> IO CInt+foreign import ccall unsafe "openssl/evp.h EVP_VerifyFinal" evpVerifyFinal :: Ptr EVP_MD_CTX -> Ptr CUChar -> CInt -> Ptr EVP_PKEY -> IO CInt foreign import ccall unsafe evpCipherContextBlockSize :: Ptr EVP_CIPHER_CTX -> IO Int @@ -129,9 +133,9 @@ withCipherCtx :: (Ptr EVP_CIPHER_CTX -> IO a) -> IO a withCipherCtx action = allocaBytes (#const sizeof(EVP_CIPHER_CTX)) $ \cctx ->- E.bracket_ (evpCipherCtxInit cctx)- (evpCipherCtxCleanup cctx)- (action cctx)+ E.bracket_ (evpCipherCtxInit cctx)+ (evpCipherCtxCleanup cctx)+ (action cctx) withMdCtx :: (Ptr EVP_MD_CTX -> IO a) -> IO a withMdCtx = allocaBytes (#const sizeof(EVP_MD_CTX))@@ -149,6 +153,17 @@ cipher = unsafePerformIO evpDesEde3Cbc md5 = unsafePerformIO evpMD5 +verifyAll :: EvpPkey -> BS.ByteString -> BS.ByteString -> IO Bool+verifyAll pkey data_ sig = do+ withMdCtx $ \mdctx -> do+ evpDigestInit mdctx md5+ withData data_ $ \a b -> evpDigestUpdate mdctx a b+ withForeignPtr pkey $ \pk -> do+ withData sig $ \a b -> do+ rv <- evpVerifyFinal mdctx a b pk+ return $ case rv of+ 1 -> True+ _ -> False signAll :: EvpPkey -> BS.ByteString -> IO BS.ByteString signAll pkey xs = withMdCtx $ \cctx -> do@@ -214,10 +229,10 @@ foreign import ccall unsafe "BN_bin2bn" bnBin2Bn :: Ptr CUChar -> CInt -> Ptr BIGNUM -> IO (Ptr BIGNUM) -newtype SHA_CTX = SHA_CTX (Ptr SHA_CTX) +newtype SHA_CTX = SHA_CTX (Ptr SHA_CTX) -foreign import ccall unsafe "SHA1_Init" sha1Init :: SHA_CTX -> IO () -foreign import ccall unsafe "SHA1_Update" sha1Update :: SHA_CTX -> Ptr a -> CULong -> IO () +foreign import ccall unsafe "SHA1_Init" sha1Init :: SHA_CTX -> IO ()+foreign import ccall unsafe "SHA1_Update" sha1Update :: SHA_CTX -> Ptr a -> CULong -> IO () foreign import ccall unsafe "SHA1_Final" sha1Final :: Ptr CChar -> SHA_CTX -> IO () @@ -233,20 +248,18 @@ bsToHex bs = BS.foldr f [] bs where f w = showHex x . showHex y where (x,y) = divMod w 16- + withSHA_CTX :: (SHA_CTX -> IO a) -> IO a withSHA_CTX action = allocaBytes (#const sizeof(SHA_CTX)) $ \cctx -> sha1Init (SHA_CTX cctx) >> action (SHA_CTX cctx) -type NEvpPkey = ForeignPtr EVP_PKEY- foreign import ccall unsafe pkeyNewRSA :: RSA -> IO (Ptr EVP_PKEY) -- foreign import ccall "&EVP_PKEY_free" evpPkeyFreePtr :: FunPtr (Ptr EVP_PKEY -> IO ()) foreign import ccall "get_KEY" evpPkeyFreePtr :: FunPtr (Ptr EVP_PKEY -> IO ()) -createPkey :: RSAElems BS.ByteString -> IO NEvpPkey+createPkey :: RSAElems BS.ByteString -> IO EvpPkey createPkey re = create_rsa re >>= create_pkey where setBn pb d = do np <- peek pb
Screen.hs view
@@ -117,10 +117,10 @@ tryDrawRenderContext rc = do y <- swapMVar (needsResize rc) False withMVar (drawingStuff rc) $ \(z,_,_) -> do- erase- when y (attemptIO endWin >> refresh)- z- refresh+ erase+ when y (attemptIO endWin >> refresh)+ z+ refresh setRenderContext rc dr = do modifyMVar_ (drawingStuff rc) $ \(_,_,final) -> do@@ -133,9 +133,9 @@ final --touchRenderContext rc return (wdr, processKey w, return (){-, nf-}) where- wdr = do- c <- newCanvas- {- eannM ("doRender " ++ show c) $ -}+ wdr = do+ c <- newCanvas+ {- eannM ("doRender " ++ show c) $ -} render w c keyRenderContext :: RenderContext -> Key -> IO Bool@@ -178,15 +178,15 @@ drawString :: Canvas -> String -> IO () drawString canvas s = {- eannM (fmtSs "drawString %s %s" [(show canvas), s]) $ -} ds ml yb (origin canvas) where- ds (s:ls) yb (x,y) | yb > 0 = tryIO (mvWAddStr (window canvas) y x (take xb s)) >> ds ls (yb - 1) (x,y + 1)- ds _ _ _ = return ()- (xb,yb) = bounds canvas- ls = lines s- (wx,wy) = widgetOrigin canvas- ml = map (mv ' ' wx) (mv "" wy ls)- mv _ 0 ss = ss- mv _ n ss | n > 0 = drop n ss- mv ec n ss = replicate (0 - n) ec ++ ss+ ds (s:ls) yb (x,y) | yb > 0 = tryIO (mvWAddStr (window canvas) y x (take xb s)) >> ds ls (yb - 1) (x,y + 1)+ ds _ _ _ = return ()+ (xb,yb) = bounds canvas+ ls = lines s+ (wx,wy) = widgetOrigin canvas+ ml = map (mv ' ' wx) (mv "" wy ls)+ mv _ 0 ss = ss+ mv _ n ss | n > 0 = drop n ss+ mv ec n ss = replicate (0 - n) ec ++ ss boundCanvas :: Maybe Int -> Maybe Int -> Canvas -> Canvas@@ -200,12 +200,12 @@ renderCentered :: Widget -> Canvas -> IO () renderCentered w canvas = do- (xs,ys) <- getBounds w- let (xs',ys') = bounds canvas- f cs ws | ws >= cs = 0- f cs ws = (cs - ws) `div` 2- nc = (canvasTranslate canvas (f xs' xs,f ys' ys))- renderChild w nc {bounds=(min xs $ fst $ bounds nc ,min ys $ snd $ bounds nc)}+ (xs,ys) <- getBounds w+ let (xs',ys') = bounds canvas+ f cs ws | ws >= cs = 0+ f cs ws = (cs - ws) `div` 2+ nc = (canvasTranslate canvas (f xs' xs,f ys' ys))+ renderChild w nc {bounds=(min xs $ fst $ bounds nc ,min ys $ snd $ bounds nc)} renderChild :: Widget -> Canvas -> IO ()@@ -229,19 +229,19 @@ pk k = tk ws k tk [] _ = return False tk (w:ws) k = do- b <- processKey w k- if b then return True else tk ws k+ b <- processKey w k+ if b then return True else tk ws k -- layout widgets -- | centers child widget, causes child to not use any extra space. centerWidget :: Widget -> Widget centerWidget w = w {render = rst} where rst canvas = do- (xs,ys) <- getBounds w- let (xs',ys') = bounds canvas- renderChild w (canvasTranslate canvas (f xs' xs,f ys' ys)) {bounds=(min xs $ fst $ bounds canvas ,min ys $ snd $ bounds canvas)} where- f cs ws | ws >= cs = 0- f cs ws = (cs - ws) `div` 2+ (xs,ys) <- getBounds w+ let (xs',ys') = bounds canvas+ renderChild w (canvasTranslate canvas (f xs' xs,f ys' ys)) {bounds=(min xs $ fst $ bounds canvas ,min ys $ snd $ bounds canvas)} where+ f cs ws | ws >= cs = 0+ f cs ws = (cs - ws) `div` 2 -- General Widgets@@ -251,18 +251,18 @@ newScrollWidget w = do yr <- newMVar 0 let rst canvas = do- y <- readMVar yr- renderChild w (canvasWTranslate canvas (0,y))- pk (KeyChar 'j') = modifyMVar_ yr (\x -> return $ x + 1) >> keyDone- pk KeyDown = modifyMVar_ yr (\x -> return $ x + 1) >> keyDone- pk (KeyChar 'k') = modifyMVar_ yr (\x -> return $ x - 1) >> keyDone- pk KeyUp = modifyMVar_ yr (\x -> return $ x - 1) >> keyDone- pk KeyHome = swapMVar yr 0 >> keyDone- pk (KeyChar 'g') = swapMVar yr 0 >> keyDone- pk KeyNPage = modifyMVar_ yr (\x -> return $ x + 25) >> keyDone- pk KeyPPage = modifyMVar_ yr (\x -> return $ x - 25) >> keyDone- pk k = processKey w k- keyDone = modifyMVar_ yr (\x -> return (max 0 x)) >> return True+ y <- readMVar yr+ renderChild w (canvasWTranslate canvas (0,y))+ pk (KeyChar 'j') = modifyMVar_ yr (\x -> return $ x + 1) >> keyDone+ pk KeyDown = modifyMVar_ yr (\x -> return $ x + 1) >> keyDone+ pk (KeyChar 'k') = modifyMVar_ yr (\x -> return $ x - 1) >> keyDone+ pk KeyUp = modifyMVar_ yr (\x -> return $ x - 1) >> keyDone+ pk KeyHome = swapMVar yr 0 >> keyDone+ pk (KeyChar 'g') = swapMVar yr 0 >> keyDone+ pk KeyNPage = modifyMVar_ yr (\x -> return $ x + 25) >> keyDone+ pk KeyPPage = modifyMVar_ yr (\x -> return $ x - 25) >> keyDone+ pk k = processKey w k+ keyDone = modifyMVar_ yr (\x -> return (max 0 x)) >> return True return w {processKey = pk, render = rst} @@ -271,14 +271,14 @@ boxWidget w = w {render = rst, getBounds = gb} where gb = getBounds w >>= \(x,y) -> return (x + 2, y + 2) rst canvas@(Canvas {bounds = (xb,yb)}) = do- -- let tb = '+' : (replicate (xb - 2) '-' ++ "+")- let tb = ulCorner ++ (replicate (xb - 2) hLine ++ urCorner)- bb = llCorner ++ (replicate (xb - 2) hLine ++ lrCorner)- bc c@(Canvas {bounds = (xb,yb)}) = c {bounds = (max (xb - 1) 0, max (yb - 1) 0)}- renderChild w (canvasTranslate (bc canvas) (1,1)) - drawString canvas tb- drawString (canvasTranslate canvas (0,yb - 1)) bb- sequence_ [drawString (canvasTranslate canvas (xt,yt)) (vLine :: String) | yt <- [1..yb - 2], xt <- [0,xb - 1]]+ -- let tb = '+' : (replicate (xb - 2) '-' ++ "+")+ let tb = ulCorner ++ (replicate (xb - 2) hLine ++ urCorner)+ bb = llCorner ++ (replicate (xb - 2) hLine ++ lrCorner)+ bc c@(Canvas {bounds = (xb,yb)}) = c {bounds = (max (xb - 1) 0, max (yb - 1) 0)}+ renderChild w (canvasTranslate (bc canvas) (1,1))+ drawString canvas tb+ drawString (canvasTranslate canvas (0,yb - 1)) bb+ sequence_ [drawString (canvasTranslate canvas (xt,yt)) (vLine :: String) | yt <- [1..yb - 2], xt <- [0,xb - 1]] {-@@ -293,35 +293,35 @@ rst canvas = drawString canvas s - + verticalBox :: [(Packing,Widget)] -> [(Packing,Widget)] -> Widget verticalBox starts ends = (childrenWidget aw) {render = rd, getBounds = gb} where awpb = starts ++ ends awp = if any isExpand $ fsts awpb then awpb else starts ++ [(Expand,emptyWidget)] ++ ends aw = snds awp gb = do- (xs,ys) <- fmap unzip $ mapM getBounds aw- return (maximum xs, sum ys)+ (xs,ys) <- fmap unzip $ mapM getBounds aw+ return (maximum xs, sum ys) rd canvas = do- let (_,yb) = bounds canvas+ let (_,yb) = bounds canvas --let ywo = snd $ widgetOrigin $ canvas- (_,ys) <- gb- let ne = length (filter isExpand $ fsts awp)- el = if yb > ys then splitSpace (yb - ys) ne else replicate ne 0- f ((e:es),canvas) (ps,w) | isExpand ps = do- (_,wby) <- getBounds w- if isFill ps then- renderChild w (boundCanvas Nothing (Just (wby + e)) canvas)- else renderCentered w (boundCanvas Nothing (Just (wby + e)) canvas)- return (es,canvasTranslate canvas (0,wby + e))- f (es,canvas) (_,w) = do- (_,wby) <- getBounds w- --renderCentered w (boundCanvas Nothing (Just wby) canvas)- renderChild w (boundCanvas Nothing (Just wby) canvas)- return (es,canvasTranslate canvas (0,wby))- foldlM_ f (el,canvas) awp+ (_,ys) <- gb+ let ne = length (filter isExpand $ fsts awp)+ el = if yb > ys then splitSpace (yb - ys) ne else replicate ne 0+ f ((e:es),canvas) (ps,w) | isExpand ps = do+ (_,wby) <- getBounds w+ if isFill ps then+ renderChild w (boundCanvas Nothing (Just (wby + e)) canvas)+ else renderCentered w (boundCanvas Nothing (Just (wby + e)) canvas)+ return (es,canvasTranslate canvas (0,wby + e))+ f (es,canvas) (_,w) = do+ (_,wby) <- getBounds w+ --renderCentered w (boundCanvas Nothing (Just wby) canvas)+ renderChild w (boundCanvas Nothing (Just wby) canvas)+ return (es,canvasTranslate canvas (0,wby))+ foldlM_ f (el,canvas) awp horizontalBox :: [(Packing,Widget)] -> [(Packing,Widget)] -> Widget@@ -330,60 +330,60 @@ awp = if any isExpand $ fsts awpb then awpb else starts ++ [(Expand,emptyWidget)] ++ ends aw = snds awp gb = do- (xs,ys) <- fmap unzip $ mapM getBounds aw- return (sum xs, maximum ys)+ (xs,ys) <- fmap unzip $ mapM getBounds aw+ return (sum xs, maximum ys) rd canvas = do- let (xb,_) = bounds canvas- (xs,_) <- gb- let ne = length (filter isExpand $ fsts awp)- el = if xb > xs then splitSpace (xb - xs) ne else replicate ne 0- f ((e:es),canvas) (ps,w) | isExpand ps = do- (wbx,_) <- getBounds w- if isFill ps then- renderChild w (boundCanvas (Just (wbx + e)) Nothing canvas)- else renderCentered w (boundCanvas (Just (wbx + e)) Nothing canvas)- return (es,canvasTranslate canvas (wbx + e,0))- f (es,canvas) (_,w) = do- (wbx,_) <- getBounds w- --renderCentered w (boundCanvas (Just wbx) Nothing canvas)- renderChild w (boundCanvas (Just wbx) Nothing canvas)- return (es,canvasTranslate canvas (wbx,0))- foldlM_ f (el,canvas) awp+ let (xb,_) = bounds canvas+ (xs,_) <- gb+ let ne = length (filter isExpand $ fsts awp)+ el = if xb > xs then splitSpace (xb - xs) ne else replicate ne 0+ f ((e:es),canvas) (ps,w) | isExpand ps = do+ (wbx,_) <- getBounds w+ if isFill ps then+ renderChild w (boundCanvas (Just (wbx + e)) Nothing canvas)+ else renderCentered w (boundCanvas (Just (wbx + e)) Nothing canvas)+ return (es,canvasTranslate canvas (wbx + e,0))+ f (es,canvas) (_,w) = do+ (wbx,_) <- getBounds w+ --renderCentered w (boundCanvas (Just wbx) Nothing canvas)+ renderChild w (boundCanvas (Just wbx) Nothing canvas)+ return (es,canvasTranslate canvas (wbx,0))+ foldlM_ f (el,canvas) awp homVerticalBox :: [(Packing,Widget)] -> Widget homVerticalBox awp = (childrenWidget aw) {render = rd, getBounds = gb } where aw = snds awp gb = do- (xs,ys) <- fmap unzip $ mapM getBounds aw- return (maximum xs, (maximum ys) * length aw)+ (xs,ys) <- fmap unzip $ mapM getBounds aw+ return (maximum xs, (maximum ys) * length aw) rd canvas = do- let (_,yb) = bounds canvas- el = splitSpace yb (length aw)- f ([],_) _ = error "no space to split"- f ((e:es),canvas) (ps,w) = do- if isFill ps then- renderChild w (boundCanvas Nothing (Just e) canvas)- else renderCentered w (boundCanvas Nothing (Just e) canvas)- return (es,canvasTranslate canvas (0,e))- foldlM_ f (el,canvas) awp+ let (_,yb) = bounds canvas+ el = splitSpace yb (length aw)+ f ([],_) _ = error "no space to split"+ f ((e:es),canvas) (ps,w) = do+ if isFill ps then+ renderChild w (boundCanvas Nothing (Just e) canvas)+ else renderCentered w (boundCanvas Nothing (Just e) canvas)+ return (es,canvasTranslate canvas (0,e))+ foldlM_ f (el,canvas) awp homHorizontalBox :: [(Packing,Widget)] -> Widget homHorizontalBox awp = (childrenWidget aw) {render = rd, getBounds = gb } where aw = snds awp gb = do- (xs,ys) <- fmap unzip $ mapM getBounds aw- return (maximum xs * length aw, maximum ys)+ (xs,ys) <- fmap unzip $ mapM getBounds aw+ return (maximum xs * length aw, maximum ys) rd canvas = do- let (xb,_) = bounds canvas- el = splitSpace xb (length aw)- f ([],_) _ = error "no space to split"- f ((e:es),canvas) (ps,w) = do- if isFill ps then- renderChild w (boundCanvas (Just e) Nothing canvas)- else renderCentered w (boundCanvas (Just e) Nothing canvas)- return (es,canvasTranslate canvas (e,0))- foldlM_ f (el,canvas) awp+ let (xb,_) = bounds canvas+ el = splitSpace xb (length aw)+ f ([],_) _ = error "no space to split"+ f ((e:es),canvas) (ps,w) = do+ if isFill ps then+ renderChild w (boundCanvas (Just e) Nothing canvas)+ else renderCentered w (boundCanvas (Just e) Nothing canvas)+ return (es,canvasTranslate canvas (e,0))+ foldlM_ f (el,canvas) awp splitSpace m n = f (m `mod` n) $ replicate n (m `div` n) where f 0 xs = xs@@ -391,21 +391,21 @@ f n' [] = errorf "splitSpace %i %i (f %i []): this can't happen." [fi m, fi n, fi n'] - + newSVarWidget :: (Readable c ) => c a -> (a -> Widget) -> Widget newSVarWidget sv f = emptyWidget {render = rw, getBounds = gb} where rw canvas = do- v <- readVal sv- render (f v) canvas+ v <- readVal sv+ render (f v) canvas gb = do- v <- readVal sv- getBounds (f v)+ v <- readVal sv+ getBounds (f v) dynamicWidget :: IO Widget -> Widget dynamicWidget w = emptyWidget {render = rw, getBounds = gb, processKey = pk {- , processEvent = pe -} } where rw canvas = do- v <- w- render v canvas+ v <- w+ render v canvas gb = w >>= getBounds pk k = w >>= \x -> processKey x k -- pe a b = w >>= \x -> processEvent x a b@@ -417,8 +417,8 @@ stackedWidgets ws@(w:_) = widgetEmpty { render = rnd, processKey = \k -> processKey w k, getBounds = gb } where rnd canvas = mapM_ (flip render canvas) (reverse ws) gb = do- bs <- mapM getBounds ws- return $ (liftT2 (maximum, maximum)) (unzip bs)+ bs <- mapM getBounds ws+ return $ (liftT2 (maximum, maximum)) (unzip bs) {- newAlternate :: Widget -> IO (Widget, Alternate)@@ -427,29 +427,29 @@ final <- connect (changedSignal w) (\() -> signal sig ()) r <- newMVar (w,final) let w = emptyWidget {render = rw, getBounds = gb, processKey = pk }- rw canvas = do- (w,_) <- readMVar r- renderChild w canvas- gb = do- (w,_) <- readMVar r- getBounds w- pk k = do- (w,_) <- readMVar r- processKey w k+ rw canvas = do+ (w,_) <- readMVar r+ renderChild w canvas+ gb = do+ (w,_) <- readMVar r+ getBounds w+ pk k = do+ (w,_) <- readMVar r+ processKey w k return (w,Alternate r sig) switchAlternate :: Alternate -> Widget -> IO () switchAlternate (Alternate mv sig) w = (modifyMVar_ mv $ \(_,final) ->- (final >> connect (changedSignal w) (\() -> signal sig ()) >>= \nf -> return (w,nf)))- >> signal sig ()+ (final >> connect (changedSignal w) (\() -> signal sig ()) >>= \nf -> return (w,nf)))+ >> signal sig () -} keyCatcherWidget :: (Curses.Key -> IO Bool) -> Widget -> Widget keyCatcherWidget kr w = w {processKey = kr'} where kr' k = do- b <- processKey w k- if b then return True else (kr k)+ b <- processKey w k+ if b then return True else (kr k) attrWidget :: Attr -> Widget -> Widget attrWidget a w = w {render = nr} where
dist/build/ginsu/ginsu-tmp/ExampleConf.hs view
@@ -58,7 +58,7 @@ "# MARK_[123..] sets the initial filter for a given marked screen. use the", "# number keys to quickly switch to a mark.", "#",- "# the default has '7' show puffs to or from you, ",+ "# the default has '7' show puffs to or from you,", "# '8' shows traffic about gale and '9' filters spoilers away.", "", "MARK_7 ~c:$GALE_ID ; ~a:$GALE_ID",@@ -67,7 +67,7 @@ "", "", "# beep on any puffs matching the following filters",- "BEEP ~c:$GALE_ID ",+ "BEEP ~c:$GALE_ID", "", "", "# number of puffs to store in pufflog on exit.",@@ -77,7 +77,7 @@ "SCROLLBACK_SIZE 0", "", "# charset, one of utf8, latin1, or ascii. if not set, will try to determine it from $LANG",- "# this only affects what format it assumes you are editing puffs in. locale settings are ",+ "# this only affects what format it assumes you are editing puffs in. locale settings are", "# always used for the UI", "#CHARSET latin1", "",@@ -95,8 +95,8 @@ "", "BROWSER links", "",- "apphook WikiWord ",- " '([[:space:]]|^)(([[:upper:]][[:lower:]]+){2,})([[:space:]]|$)' ",+ "apphook WikiWord",+ " '([[:space:]]|^)(([[:upper:]][[:lower:]]+){2,})([[:space:]]|$)'", " '$BROWSER http://wiki.ofb.net/?$2'", " '$2'", "",@@ -106,10 +106,10 @@ "", "#default key bindings", "",- "bind <F1> show_help_screen ",+ "bind <F1> show_help_screen", "bind ? show_help_screen",- "#bind <F2> show_main_index ",- "bind <F3> show_presence_status ",+ "#bind <F2> show_main_index",+ "bind <F3> show_presence_status", "", "bind j next_puff", "bind k previous_puff",@@ -172,5 +172,5 @@ "bind <C-l> redraw_screen", "bind v goto_match", "bind S show_status_screen",- " ",+ "", ""]
dist/build/ginsu/ginsu-tmp/KeyHelpTable.hs view
@@ -1,53 +1,53 @@ module KeyHelpTable(keyHelpTable) where keyHelpTable gk = [- Left "Main Screens"- ,Right (gk "show_help_screen", "Show help screen")- ,Right (gk "show_presence_status", "show presence status")- ,Right (gk "show_puff_details", "show puff details")- ,Right (gk "show_status_screen", "show status screen")- ,Left "Puff Movement"- ,Right (gk "next_puff", "Goto the next puff")- ,Right (gk "previous_puff", "Goto the previous puff")- ,Right (gk "first_puff", "Goto the first puff")- ,Right (gk "last_puff", "Goto the last puff")- ,Right (gk "next_line", "Scroll one line down")- ,Right (gk "previous_line", "Scroll one line up")- ,Right (gk "next_page", "Scroll one page down")- ,Right (gk "previous_page", "Scroll one page up")- ,Right (gk "forward_half_page", "Scroll a half page down")- ,Right (gk "backward_half_page", "Scroll a half page up")- ,Left "Filter Manipulation"- ,Right (gk "prompt_new_filter", "prompt new filter")- ,Right (gk "prompt_new_filter_slash", "prompt new filter slash")- ,Right (gk "prompt_new_filter_twiddle", "prompt new filter twiddle")- ,Right (gk "pop_one_filter", "pop one filter")- ,Right (gk "pop_all_filters", "pop all filters")- ,Right (gk "invert_filter", "invert filter")- ,Right (gk "filter_current_thread", "filter current thread")- ,Right (gk "swap_filters", "swap filters")- ,Right (gk "filter_current_author", "filter current author")- ,Left "Puff Body Filtering"- ,Right (gk "toggle_rot13", "toggle Rot13 filter")- ,Left "Mark/Workspace Manipulation"- ,Right (gk "set_mark", "save current position at a given mark.")- ,Right (gk "recall_mark", "goto position saved at mark")- ,Right (gk "set_filter_mark", "save current filter stack at given mark.")- ,Right (gk "recall_filter_mark", "Recall filter stack at mark")- ,Right (gk "recall_combine_mark", "Recall filter stack at mark and combine it with the current filter stack.")- ,Right ("[1-9]", "Recall given numbered workspace and set it as current workspace, these follow marks [1-9]")- ,Left "Composing Puffs"- ,Right (gk "new_puff", "compose a new puff")- ,Right (gk "follow_up", "follow up to the same category as the current puff")- ,Right (gk "reply_to_author", "reply to the author of the current puff privatly")- ,Right (gk "group_reply", "reply to the union of the sender and categories of the current puff")- ,Right (gk "resend_puff", "resend puff")- ,Left "Miscellaneous"- ,Right (gk "goto_match", "visit link in current puff")- ,Right (gk "modify_presence_string", "modify presence string")- ,Right (gk "reconnect_to_servers", "reconnect to servers")- ,Right (gk "edit_config_file", "Edit the configuration file and reload its settings")- ,Right (gk "ask_quit", "quit ginsu")- ,Right (gk "fast_quit", "quit ginsu without asking first")- ,Right (gk "redraw_screen", "redraw screen")- ]+ Left "Main Screens"+ ,Right (gk "show_help_screen", "Show help screen")+ ,Right (gk "show_presence_status", "show presence status")+ ,Right (gk "show_puff_details", "show puff details")+ ,Right (gk "show_status_screen", "show status screen")+ ,Left "Puff Movement"+ ,Right (gk "next_puff", "Goto the next puff")+ ,Right (gk "previous_puff", "Goto the previous puff")+ ,Right (gk "first_puff", "Goto the first puff")+ ,Right (gk "last_puff", "Goto the last puff")+ ,Right (gk "next_line", "Scroll one line down")+ ,Right (gk "previous_line", "Scroll one line up")+ ,Right (gk "next_page", "Scroll one page down")+ ,Right (gk "previous_page", "Scroll one page up")+ ,Right (gk "forward_half_page", "Scroll a half page down")+ ,Right (gk "backward_half_page", "Scroll a half page up")+ ,Left "Filter Manipulation"+ ,Right (gk "prompt_new_filter", "prompt new filter")+ ,Right (gk "prompt_new_filter_slash", "prompt new filter slash")+ ,Right (gk "prompt_new_filter_twiddle", "prompt new filter twiddle")+ ,Right (gk "pop_one_filter", "pop one filter")+ ,Right (gk "pop_all_filters", "pop all filters")+ ,Right (gk "invert_filter", "invert filter")+ ,Right (gk "filter_current_thread", "filter current thread")+ ,Right (gk "swap_filters", "swap filters")+ ,Right (gk "filter_current_author", "filter current author")+ ,Left "Puff Body Filtering"+ ,Right (gk "toggle_rot13", "toggle Rot13 filter")+ ,Left "Mark/Workspace Manipulation"+ ,Right (gk "set_mark", "save current position at a given mark.")+ ,Right (gk "recall_mark", "goto position saved at mark")+ ,Right (gk "set_filter_mark", "save current filter stack at given mark.")+ ,Right (gk "recall_filter_mark", "Recall filter stack at mark")+ ,Right (gk "recall_combine_mark", "Recall filter stack at mark and combine it with the current filter stack.")+ ,Right ("[1-9]", "Recall given numbered workspace and set it as current workspace, these follow marks [1-9]")+ ,Left "Composing Puffs"+ ,Right (gk "new_puff", "compose a new puff")+ ,Right (gk "follow_up", "follow up to the same category as the current puff")+ ,Right (gk "reply_to_author", "reply to the author of the current puff privatly")+ ,Right (gk "group_reply", "reply to the union of the sender and categories of the current puff")+ ,Right (gk "resend_puff", "resend puff")+ ,Left "Miscellaneous"+ ,Right (gk "goto_match", "visit link in current puff")+ ,Right (gk "modify_presence_string", "modify presence string")+ ,Right (gk "reconnect_to_servers", "reconnect to servers")+ ,Right (gk "edit_config_file", "Edit the configuration file and reload its settings")+ ,Right (gk "ask_quit", "quit ginsu")+ ,Right (gk "fast_quit", "quit ginsu without asking first")+ ,Right (gk "redraw_screen", "redraw screen")+ ]
docs/Changelog.old view
@@ -8,9 +8,9 @@ Revision: ginsu--main--0.6--patch-45 - - ++ modified files: .arch-inventory CWString.hsc Changelog Charset.hs Curses.hsc EIO.hs ErrorLog.hs Gale.hs GinsuConfig.hs Main.hs Makefile.am@@ -28,9 +28,9 @@ Revision: ginsu--main--0.6--patch-44 - - ++ modified files: Changelog Makefile.am @@ -42,12 +42,12 @@ Revision: ginsu--main--0.6--patch-43 - Color support + Color support major filter changes, based on boolean library now.- - - +++ new files: Boolean/.arch-ids/=id Boolean/Algebra.hs unicode_map.txt @@ -67,14 +67,14 @@ 2004-08-12 06:06:27 GMT John Meacham <john@repetae.net> patch-42 Summary:- + Revision: ginsu--main--0.6--patch-42 made error messages modal, instead of using status line switched to parsec for parsing filters, better error messages added general status screen on 'S'- added ?encrypted and ?signed + added ?encrypted and ?signed added /foo to search everything for foo added log buffer on status screen @@ -103,15 +103,15 @@ 2004-07-21 23:50:12 GMT John Meacham <john@repetae.net> patch-40 Summary:- fix puff parsing bug + fix puff parsing bug Revision: ginsu--main--0.6--patch-40 parse top level text fragments properly create better error messages on malformed puff don't try to reconnect to server because of malformed puff- + modified files: Atom.hs Changelog Gale.hs UArrayParser.hs @@ -135,9 +135,9 @@ Revision: ginsu--main--0.6--patch-38 - - ++ modified files: .arch-inventory Changelog @@ -149,11 +149,11 @@ Revision: ginsu--main--0.6--patch-37 - no longer cache word-wrapped text. + no longer cache word-wrapped text. much more efficient utf8 decoding. hash function for atoms better.- + modified files: Atom.hs Changelog Filter.hs Main.hs PackedString.hs configure.in@@ -217,21 +217,21 @@ 2004-07-02 21:12:39 GMT John Meacham <john@repetae.net> patch-32 Summary:- added azz patches, fix static build + added azz patches, fix static build Revision: ginsu--main--0.6--patch-32 - - ++ Patches applied:- + * azz@offog.org--2004/ginsu--azz--0.1--base-0 tag of john@repetae.net--2004/ginsu--main--0.6--patch-31- + * azz@offog.org--2004/ginsu--azz--0.1--patch-1 don't hide last line when using filters- + modified files: Changelog Main.hs Makefile.am @@ -303,13 +303,13 @@ 2004-04-23 00:14:58 GMT John Meacham <john@repetae.net> patch-26 Summary:- AKD wrapup. dates + AKD wrapup. dates Revision: ginsu--main--0.6--patch-26 PUFF_DATE_FORMAT string similar to 'date' command for how you want the date to be displayed in your puff window- + participates in AKD semi-properly. populates .gale/auth/cache on its own modified files:@@ -328,8 +328,8 @@ print hash of data fragments use ACS macros even if we have wide character support made sure it compiles without ncursesw- + modified files: Changelog Curses.hsc KeyCache.hs Puff.hs SHA1.hs configure.in my_curses.h@@ -346,9 +346,9 @@ made it use ncursesw if it exists uses line drawing characters in display now fixed problems with long utf8 lines when ncursesw is installed- - ++ new files: ac-macros/.arch-ids/curslib.m4.id ac-macros/.arch-ids/funcdecl.m4.id ac-macros/curslib.m4@@ -378,8 +378,8 @@ Revision: ginsu--main--0.6--patch-22 - + modified files: Changelog GinsuConfig.hs RSA.hsc @@ -473,8 +473,8 @@ Completly revamped the mark system. now you can set position and filter marks independently Workspaces are built on top of the marks.- + new files: DocLike.hs @@ -490,9 +490,9 @@ Revision: ginsu--main--0.6--patch-14 - - ++ modified files: Changelog ErrorLog.hs @@ -548,7 +548,7 @@ 2004-03-16 05:31:40 GMT John Meacham <john@repetae.net> patch-9 Summary:- Key mapping + Key mapping Revision: ginsu--main--0.6--patch-9 @@ -569,7 +569,7 @@ 2004-03-16 00:59:42 GMT John Meacham <john@repetae.net> patch-8 Summary:- + Revision: ginsu--main--0.6--patch-8 @@ -642,7 +642,7 @@ goto_match ('v' by default) will extract urls or WikiWords and let you access them with a web browser. The mechanism is generic and may extract arbitrary- regular expressions and run arbitrary programs on them. + regular expressions and run arbitrary programs on them. new files: Regex.hs@@ -655,7 +655,7 @@ 2004-03-04 03:49:59 GMT John Meacham <john@repetae.net> patch-3 Summary:- Cleanups + Cleanups Revision: ginsu--main--0.6--patch-3 @@ -683,9 +683,9 @@ ginsu--main--0.6--patch-2 fixed filters to use regular expressions. simplified code in several ways.- - ++ modified files: Changelog Filter.hs Puff.hs @@ -709,7 +709,7 @@ Revision: ginsu--main--0.6--base-0 - + (automatically generated log message) new files:@@ -731,12 +731,12 @@ 0.5.3 changed id/class to use '/' convention rebindable keys via 'bind' in config file- can derive GALE_DOMAIN from GALE_ID if necessary + can derive GALE_DOMAIN from GALE_ID if necessary added '?' as extra help key fixed problem with generated C code. 0.5.2- new pufflog format. + new pufflog format. fixed some memory leaks. fixed '-e' thanks to Adam Sampson builds cleanly with ghc 6.2 now.@@ -745,7 +745,7 @@ line editing for entering filters now works. supported are arrow keys, backspace, home,end, ^K to delete to end of line added EDITOR_NEWPUFF_OPTION for options to be passed to the editor- when puffing to no categories + when puffing to no categories added NO_PRESENCE_NOTIFY to stop presence status puffs from being generated. changed checkconfig output for GALE_SUBSCRIBE@@ -767,7 +767,7 @@ Makefile cleanups requires ghc 6.0 Fixed terminal cooruption caused by nonprintable characters in puffs- now uses ISO C90 charset conversion routines. + now uses ISO C90 charset conversion routines. fixed some problems with charset detection much much improved autoconf/automake setup scrolls to bottom of screen on incoming puff when already at bottom only@@ -788,191 +788,191 @@ 0.4.6- switched to -O2 for performance- better locale support.- added quit confirmation (shift-Q to quit immediatly)- added filter documentation to help screen- fixed docs for key notation consistancy- added --enable-unopt for unoptimized builds- added EDITOR_OPTION to pass arguments to your puff editor- added puff sending confirmation screen this lets you- - set return receipts manually- - send anonymous puffs- - reedit puffs - - abort puffs- expanded dialogs- + switched to -O2 for performance+ better locale support.+ added quit confirmation (shift-Q to quit immediatly)+ added filter documentation to help screen+ fixed docs for key notation consistancy+ added --enable-unopt for unoptimized builds+ added EDITOR_OPTION to pass arguments to your puff editor+ added puff sending confirmation screen this lets you+ - set return receipts manually+ - send anonymous puffs+ - reedit puffs+ - abort puffs+ expanded dialogs+ 0.4.5- changed key notation to angle notation <C-x><space> etc..- ON_INCOMING_PUFF works as expected now- angle notation can be used in config file.- popup informational windows for certain modal actions added- scrolling window responds to <PageUp> and <PageDown>- cursor handling much more robust/consistant- numerous internal changes- now compiles via-c for better optimization and profiling- './configure --enable-profile' will enable profiling support.- sends \r\n instead of \n because some clients get confused otherwise.- ignores SIGPIPE, just in case.- fixed space leak on reading pufflog.+ changed key notation to angle notation <C-x><space> etc..+ ON_INCOMING_PUFF works as expected now+ angle notation can be used in config file.+ popup informational windows for certain modal actions added+ scrolling window responds to <PageUp> and <PageDown>+ cursor handling much more robust/consistant+ numerous internal changes+ now compiles via-c for better optimization and profiling+ './configure --enable-profile' will enable profiling support.+ sends \r\n instead of \n because some clients get confused otherwise.+ ignores SIGPIPE, just in case.+ fixed space leak on reading pufflog. 0.4.4- implemented full server side of IdleTimeProtocol (by popular request)- prettier printing of aliases- added --checkconfig to verify configuration. if you are having- trouble, use this.- updated man page.- doesnt display all whitespace puffs from _gale.* + implemented full server side of IdleTimeProtocol (by popular request)+ prettier printing of aliases+ added --checkconfig to verify configuration. if you are having+ trouble, use this.+ updated man page.+ doesnt display all whitespace puffs from _gale.* 0.4.3- added presence screen via 'F3', lists all users and their status.- answers return reciepts now.- notice/presence returns idle time.- requests return reciepts on 'private' puffs- outgoing 'private' puffs placed in incoming puff queue.- 'Will' a puff to reset presence when ginsu dies.- uses GALE_PRESENCE if set.- changed configuration file syntax to match that of .gale/conf- added ~i for case insensitive search.- updated internal docs- outputs error message if it can't parse the MARK_ statements.- filter parser now parses () and ; properly.- looks for .gpri files- uses $GALE_DIR if available.- prints out useful preferences to errorlog- puff details screen available via 'd'+ added presence screen via 'F3', lists all users and their status.+ answers return reciepts now.+ notice/presence returns idle time.+ requests return reciepts on 'private' puffs+ outgoing 'private' puffs placed in incoming puff queue.+ 'Will' a puff to reset presence when ginsu dies.+ uses GALE_PRESENCE if set.+ changed configuration file syntax to match that of .gale/conf+ added ~i for case insensitive search.+ updated internal docs+ outputs error message if it can't parse the MARK_ statements.+ filter parser now parses () and ; properly.+ looks for .gpri files+ uses $GALE_DIR if available.+ prints out useful preferences to errorlog+ puff details screen available via 'd' 0.4.2- handles fragments around security/encryption fragments properly (oops)- adds _ginsu.timestamp and _ginsu.spumbuster to incoming puffs now.- most errorlog messages supressed unless '-v' (info) or '-vv' (debug)- are specified on the command line.- seperated pufflog command line options to allow just not writing to- pufflog (but still read it on startup)- tweaked fragment printing in logs to keep them pretty.- sanified puff numbering- UI much less redraw-crazy. should improve responsiveness.- resizing much smarter. still flickers, but not as much.- uses $LOGNAME and $USER in preference to getlogin(3)- scrollable help screen for small terminals.- filters appear on own line when needed.- message string used for puff author- uses _ginsu.timestamp if no id/time available.- added '/' to substring match puffs- hides cursor if editor leaves it unhidden.+ handles fragments around security/encryption fragments properly (oops)+ adds _ginsu.timestamp and _ginsu.spumbuster to incoming puffs now.+ most errorlog messages supressed unless '-v' (info) or '-vv' (debug)+ are specified on the command line.+ seperated pufflog command line options to allow just not writing to+ pufflog (but still read it on startup)+ tweaked fragment printing in logs to keep them pretty.+ sanified puff numbering+ UI much less redraw-crazy. should improve responsiveness.+ resizing much smarter. still flickers, but not as much.+ uses $LOGNAME and $USER in preference to getlogin(3)+ scrollable help screen for small terminals.+ filters appear on own line when needed.+ message string used for puff author+ uses _ginsu.timestamp if no id/time available.+ added '/' to substring match puffs+ hides cursor if editor leaves it unhidden. 0.4.1- SIGWINCH now caught to resize terminal screen (bug 194) - DISABLE_SIGWINCH is a config option if this is causing trouble- now expands to GALE_DOMAIN if no alias matches (bug 200)- fix for different versions of OpenSSL (bug 195)- .spec file added for building RPMS- hsc2hs rebuilds files for all source builds. probably what is wanted.- redid Puff deconstruction, now works for more unusual but technically- valid types of puff.- added id/instance fragment to satisfy certain loggers- made printing of fragment lists cosmetically prettier.- added --testCurses to print out some curses debugging info.- added --dumpKey to print info about a keyfile.- added --errorlog to choose file to output errors too.- doesnt get confused by jgaled tracking fragments- ^L does an endwin >> refresh.+ SIGWINCH now caught to resize terminal screen (bug 194)+ DISABLE_SIGWINCH is a config option if this is causing trouble+ now expands to GALE_DOMAIN if no alias matches (bug 200)+ fix for different versions of OpenSSL (bug 195)+ .spec file added for building RPMS+ hsc2hs rebuilds files for all source builds. probably what is wanted.+ redid Puff deconstruction, now works for more unusual but technically+ valid types of puff.+ added id/instance fragment to satisfy certain loggers+ made printing of fragment lists cosmetically prettier.+ added --testCurses to print out some curses debugging info.+ added --dumpKey to print info about a keyfile.+ added --errorlog to choose file to output errors too.+ doesnt get confused by jgaled tracking fragments+ ^L does an endwin >> refresh. -0.4.0 - *** NOW is stand alone. can send signed puffs natively! wing-go! ***- reads ~/.gale/aliases/ for aliases- uses GALE_DOMAIN, GALE_ID, GALE_NAME as appropriate.- simplified Curses interface to take advantage of newer FFI features- added simple man page "ginsu (1)"- robustified key parsing code. should work with all known styles of key- cleaned up location of many routines- made it compile when ghc is installed in wierd places- added displays to let user know what is happening during delays- added -P to stop loading and saving of pufflog.- unified private key caching for sending and recieving puffs.- key cacheing no longer uses tricky tricks.- Sending Puffs is done in background thread in case it takes a while.- smarter error handling and retrying. better errorlog format.- SIGINT now caught, kills app nicely.- added ON_INCOMING_PUFF which is a macro run whenever a puff arrives. *EXP*+0.4.0+ *** NOW is stand alone. can send signed puffs natively! wing-go! ***+ reads ~/.gale/aliases/ for aliases+ uses GALE_DOMAIN, GALE_ID, GALE_NAME as appropriate.+ simplified Curses interface to take advantage of newer FFI features+ added simple man page "ginsu (1)"+ robustified key parsing code. should work with all known styles of key+ cleaned up location of many routines+ made it compile when ghc is installed in wierd places+ added displays to let user know what is happening during delays+ added -P to stop loading and saving of pufflog.+ unified private key caching for sending and recieving puffs.+ key cacheing no longer uses tricky tricks.+ Sending Puffs is done in background thread in case it takes a while.+ smarter error handling and retrying. better errorlog format.+ SIGINT now caught, kills app nicely.+ added ON_INCOMING_PUFF which is a macro run whenever a puff arrives. *EXP* 0.3.9- added PRESERVED_KEYWORDS which is a list of keywords which should be carried- over when replying to or following up on a puff.- BEEP functionality now works when terminal supports it.- ON_STARTUP added which is a macro that is run at startup- fixed sender vs. author sillyness- ~t means ~c until category closure code is finished- quoting fixed when sending things to the shell.+ added PRESERVED_KEYWORDS which is a list of keywords which should be carried+ over when replying to or following up on a puff.+ BEEP functionality now works when terminal supports it.+ ON_STARTUP added which is a macro that is run at startup+ fixed sender vs. author sillyness+ ~t means ~c until category closure code is finished+ quoting fixed when sending things to the shell. 0.3.8- now utilizes GALE_PROXY if set, otherwise it will only connect to one server- all configuration varibles may be set in the enviornment now- added locks around errorlog to keep long entries from getting mangled- used MVar for reading new config file, potential obscure bug fix.- pufflog now atomically replaces pufflog file via renaming, MVars used in BitHandle- pufflog is updated every 30 seconds if new puffs have been recieved.- ** fixed major bug in openssl layer. cleaned up layer and memory usage considerably- BitHandle speedups, uses strict fields+ now utilizes GALE_PROXY if set, otherwise it will only connect to one server+ all configuration varibles may be set in the enviornment now+ added locks around errorlog to keep long entries from getting mangled+ used MVar for reading new config file, potential obscure bug fix.+ pufflog now atomically replaces pufflog file via renaming, MVars used in BitHandle+ pufflog is updated every 30 seconds if new puffs have been recieved.+ ** fixed major bug in openssl layer. cleaned up layer and memory usage considerably+ BitHandle speedups, uses strict fields 0.3.7- fixed some potential problems when compiling with optimization- now ~ implicity starts filter addition- now compiles with -O -fasm- got rid of mySystem wackyness- seperated Message out of Puffs (note: add Messages somewhere else)- made calling out to external programs more robust- pufflog now 'packed'. saves factor of 8- code cleanups, moved out Puff and EIO functionality+ fixed some potential problems when compiling with optimization+ now ~ implicity starts filter addition+ now compiles with -O -fasm+ got rid of mySystem wackyness+ seperated Message out of Puffs (note: add Messages somewhere else)+ made calling out to external programs more robust+ pufflog now 'packed'. saves factor of 8+ code cleanups, moved out Puff and EIO functionality 0.3.6- compose with nothing selected works now- added /usr/local as alternate for ghc install- added URL's to help screen.- changed puff sending keys to p,r,f to match newsreader convention- now you add filters with 'c'- added PUFFLOG_SIZE config option- added EDITOR, GSEND configuration option- added -t id/class=ginsu to gsend (doesn't seem to work.)- UNICODE support! add a 'CHARSET utf8|latin1|ascii' line to your ginsu.config- make sure your terminal supports the given charset.+ compose with nothing selected works now+ added /usr/local as alternate for ghc install+ added URL's to help screen.+ changed puff sending keys to p,r,f to match newsreader convention+ now you add filters with 'c'+ added PUFFLOG_SIZE config option+ added EDITOR, GSEND configuration option+ added -t id/class=ginsu to gsend (doesn't seem to work.)+ UNICODE support! add a 'CHARSET utf8|latin1|ascii' line to your ginsu.config+ make sure your terminal supports the given charset. 0.3.5- included sample config in binary distribution- added ^E ^Y ^F ^B ^U ^D - added 'a' to documentation- added emptyPuff thread to help keep gale connections alive. (needs work)- added pagedown/pageup with the obvious meaning- added 'E' to edit and reload configuration file- improved filter parser- disposed of unnecisary redraw thread- added r,e,c to compose puffs, 'gsend' is needed for sending and $EDITOR- is used for editing the puff.+ included sample config in binary distribution+ added ^E ^Y ^F ^B ^U ^D+ added 'a' to documentation+ added emptyPuff thread to help keep gale connections alive. (needs work)+ added pagedown/pageup with the obvious meaning+ added 'E' to edit and reload configuration file+ improved filter parser+ disposed of unnecisary redraw thread+ added r,e,c to compose puffs, 'gsend' is needed for sending and $EDITOR+ is used for editing the puff. 0.3.4- added '\b' as alias for backspace- added '@' and '/' in cat and keyword displays- fixed curs_set problem on some terminals- added ESC as alternate for help key- greatly increased pufflog reading and writing effeciency. (still space inefficient)- improved unexpected error handling in some cases.- basic cryptography! ginsu will decrypt puffs for which a key can be found in- ~/.gale/auth/private- made parsers much more robust against malformed data- now writes errors to log file ~/.gale/ginsu.errorlog+ added '\b' as alias for backspace+ added '@' and '/' in cat and keyword displays+ fixed curs_set problem on some terminals+ added ESC as alternate for help key+ greatly increased pufflog reading and writing effeciency. (still space inefficient)+ improved unexpected error handling in some cases.+ basic cryptography! ginsu will decrypt puffs for which a key can be found in+ ~/.gale/auth/private+ made parsers much more robust against malformed data+ now writes errors to log file ~/.gale/ginsu.errorlog 0.3.3- made gale code more robust against network errors- finished puff persistance (stored in ~/.gale/ginsu.pufflog)+ made gale code more robust against network errors+ finished puff persistance (stored in ~/.gale/ginsu.pufflog) 0.3.2- added changelog- recenter screen on filter change.- added R to reconnect to server- added 'f' to add to filter stack- started work on s,S- add string entry routines (cheezy, needs work)- began work on puff persistance- + added changelog+ recenter screen on filter change.+ added R to reconnect to server+ added 'f' to add to filter stack+ started work on s,S+ add string entry routines (cheezy, needs work)+ began work on puff persistance+ 0.3.1- initial release+ initial release
docs/ginsu.1 view
@@ -26,9 +26,9 @@ .SH DESCRIPTION .BR "ginsu"-is a client for the +is a client for the .BR "gale chat system"-which can be learned about at +which can be learned about at .BR "<http://gale.org/>" To get started, generate a configuration file using the following command:@@ -41,11 +41,11 @@ .SH USING GINSU - Keys: + Keys: <F1> Help Screen <F2> Main Screen <F3> Presence Status Screen- + j next puff k previous puff <Home> first puff@@ -56,9 +56,9 @@ <C-B> <PgUp> back one page <C-D> forward one half-page <C-U> back one half-page- + d Show puff details- + c ~ add new filter u pop one filter U pop all filters@@ -70,15 +70,15 @@ m[1-9] set mark - save current filter stack at given key [1-9] recall filter stack saved here with 'm' C[1-9] recall filter stack and add it to current filter stack- + <C-O> toggle Rot13 body filter- + f follow-up to category p compose new puff r reply to author g group reply, sends to recipients and author of puff N modify public presence string- + <C-R> reconnect to all servers E edit and reload configuration file q Q quit program@@ -93,7 +93,7 @@ the filters on the stack are conjoined together to determine which puffs are visible -Primitive Filters: +Primitive Filters: ~a author ~c category ~i case insensitive substring search@@ -115,7 +115,7 @@ GINSU_FOO in the environment FOO in the config file FOO in the environment- + .SH FILES .TP .BR "~/.gale/ginsu.config"@@ -130,16 +130,16 @@ .BR "~/.gale/auth/private/*" this is where ginsu looks for your private key for decoding incoming encrypted messages. .SH BUGS-To report a bug go to +To report a bug go to .BR "<http://bugs.ofb.net/cgi-bin/bugzilla/enter_bug.cgi?product=Ginsu>"-When reporting a bug, include the last few lines of +When reporting a bug, include the last few lines of .BR "~/.gale/ginsu.errorlog" if it seems appropriate as well as the output from .BR "ginsu --checkconfig" .SH AUTHOR-ginsu was written by John Meacham. -The homepage is at +ginsu was written by John Meacham.+The homepage is at .BR "<http://repetae.net/john/computer/ginsu/>"
docs/wiki.css view
@@ -26,7 +26,7 @@ margin:0; background:#fff; color:#000;-} +} div.header img, div.footer img { border:0; padding:0; margin:0; } @@ -65,7 +65,7 @@ margin-top: 5px; border-bottom: 2px solid #000000; text-decoration:none;- display:block; + display:block; } p a.definition:hover {@@ -88,7 +88,7 @@ border:none; color:black; background-color:#000;- height:2px; + height:2px; margin-top:2ex; } div.footer hr { height:4px; }
gen_keyhelp.prl view
@@ -48,8 +48,8 @@ while (<$cfd>) { next unless /^bind\s+(\S+)\s+(\w+)\s*$/;- push @{$cm{$2}}, $1; - } + push @{$cm{$2}}, $1;+ } } @@ -58,7 +58,7 @@ print "|| <b>Action Name</b> || <b>Default Key</b> || <b>Description</b> ||\n" unless $o{h}; print "module KeyHelpTable(keyHelpTable) where\n\n" if $o{h};-print "keyHelpTable gk = [\n" if $o{h}; +print "keyHelpTable gk = [\n" if $o{h}; while (<>) { next if /^\s*(\#.*)?\s*$/;@@ -67,6 +67,6 @@ key($1, $2),next if /^(\w*)\s*(.+?)?\s*$/; } -print "\t ", join("\n\t,", @hs), "\n";+print " ", join("\n ,", @hs), "\n"; -print "\t]\n" if $o{h}; +print " ]\n" if $o{h};
ginsu.cabal view
@@ -1,10 +1,10 @@ -- vim:et Name: ginsu-Version: 0.8.1.1+Version: 0.8.2 Copyright: 2002-2009 John Meacham <john@repetae.net>- 2011-2012 Dylan Simon <dylan@dylex.net>+ 2011-2012 Dylan Simon <dylan@dylex.net> Author: John Meacham <john@foo.net>- Dylan Simon <dylan@dylex.net>+ Dylan Simon <dylan@dylex.net> Maintainer: dylan@dylex.net License: MIT License-File: LICENSE@@ -14,22 +14,22 @@ Category: Network,Console Build-Type: Custom Cabal-Version: >= 1.6-tested-with: GHC == 7.8.4, GHC == 7.10.1-extra-source-files: +tested-with: GHC == 7.8.4, GHC == 7.10.2+extra-source-files: configure ginsu.buildinfo.in config.h.in- gen_keyhelp.prl- actions.def- ginsu-mdk - my_curses.h- my_rsa.h- Boolean/README- docs/Changelog.old- docs/ginsu-manual.html- docs/wiki.css- docs/ginsu-manual.txt- docs/ginsu.1+ gen_keyhelp.prl+ actions.def+ ginsu-mdk+ my_curses.h+ my_rsa.h+ Boolean/README+ docs/Changelog.old+ docs/ginsu-manual.html+ docs/wiki.css+ docs/ginsu-manual.txt+ docs/ginsu.1 data-files: ginsu.config.sample Source-Repository head@@ -79,8 +79,9 @@ my_curses.c my_rsa.c Include-Dirs: .- Build-Depends: + Build-Depends: base >= 4 && < 5,+ async, bytestring, old-locale, containers,
ginsu.config.sample view
@@ -51,7 +51,7 @@ # MARK_[123..] sets the initial filter for a given marked screen. use the # number keys to quickly switch to a mark. #-# the default has '7' show puffs to or from you, +# the default has '7' show puffs to or from you, # '8' shows traffic about gale and '9' filters spoilers away. MARK_7 ~c:$GALE_ID ; ~a:$GALE_ID@@ -60,7 +60,7 @@ # beep on any puffs matching the following filters-BEEP ~c:$GALE_ID +BEEP ~c:$GALE_ID # number of puffs to store in pufflog on exit.@@ -70,7 +70,7 @@ SCROLLBACK_SIZE 0 # charset, one of utf8, latin1, or ascii. if not set, will try to determine it from $LANG-# this only affects what format it assumes you are editing puffs in. locale settings are +# this only affects what format it assumes you are editing puffs in. locale settings are # always used for the UI #CHARSET latin1 @@ -88,8 +88,8 @@ BROWSER links -apphook WikiWord - '([[:space:]]|^)(([[:upper:]][[:lower:]]+){2,})([[:space:]]|$)' +apphook WikiWord+ '([[:space:]]|^)(([[:upper:]][[:lower:]]+){2,})([[:space:]]|$)' '$BROWSER http://wiki.ofb.net/?$2' '$2' @@ -99,10 +99,10 @@ #default key bindings -bind <F1> show_help_screen +bind <F1> show_help_screen bind ? show_help_screen-#bind <F2> show_main_index -bind <F3> show_presence_status +#bind <F2> show_main_index+bind <F3> show_presence_status bind j next_puff bind k previous_puff@@ -165,4 +165,4 @@ bind <C-l> redraw_screen bind v goto_match bind S show_status_screen- +
my_curses.h view
@@ -10,7 +10,7 @@ #include "config.h" #endif -#if HAVE_NCURSESW_NCURSES_H +#if HAVE_NCURSESW_NCURSES_H #include <ncursesw/ncurses.h> #elif HAVE_NCURSES_NCURSES_H #include <ncurses/ncurses.h>