-
Notifications
You must be signed in to change notification settings - Fork 0
/
Shell.hs
193 lines (168 loc) · 6.69 KB
/
Shell.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
{-# LANGUAGE StandaloneDeriving, FlexibleContexts, DeriveDataTypeable #-}
module Main (main) where
import Control.Monad.IO.Class
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import Data.Char
import Data.Dynamic
import Data.List
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Word
import Numeric
import System.Console.Haskeline
import System.Environment
import qualified Data.Digest.MD5 as MD5
import Network.Protocol.SSH
instance (Typeable (m a)) => Typeable (InputT m a) where
typeOf x = mkTyConApp (mkTyCon "System.Console.Haskeline.InputT") []
data CommandCategory = StandardCommand
| MessageDigestCommand
| CipherCommand
deriving (Eq)
data Command = Command CommandCategory
String
[Parameter]
[Parameter]
Dynamic
data Parameter = StringParameter
| InputFileParameter
main :: IO ()
main = do
runInputT defaultSettings main'
where main' :: InputT IO ()
main' = do
arguments <- liftIO $ getArgs
case arguments of
[] -> commandLoop
(command:parameters) ->
processCommand (map toLower command) parameters
commandLoop :: InputT IO ()
commandLoop = do
input <- getInputLine "Crypto> "
case fmap smartWords input of
Nothing -> return ()
Just [] -> commandLoop
Just (command:parameters)
| map toLower command == "quit" -> return ()
| otherwise -> do
processCommand (map toLower command) parameters
commandLoop
processCommand :: String -> [String] -> InputT IO ()
processCommand commandName parameters = do
case parameters of
[] -> commandHelp Nothing
[item] -> commandHelp (Just item)
_ -> return ()
commandTable :: Map String Command
commandTable =
Map.fromList [("help", Command StandardCommand
"help"
[]
[StringParameter]
$ toDyn commandHelp),
("md5", Command MessageDigestCommand
"md5"
[InputFileParameter]
[]
$ toDyn commandMD5)]
commandHelp :: Maybe String -> InputT IO ()
commandHelp maybeCommandName = do
case maybeCommandName of
Nothing -> do
outputStrLn $ "Standard commands:"
outputTabularList $ commandNamesForCategory StandardCommand
outputStrLn $ "Message digest commands:"
outputTabularList $ commandNamesForCategory MessageDigestCommand
outputStrLn $ "Cipher commands:"
outputTabularList $ commandNamesForCategory CipherCommand
outputStrLn $ ""
Just commandName -> do
case Map.lookup commandName commandTable of
Nothing -> do
outputStrLn $ "No command by that name."
outputStrLn $ ""
Just (Command _
_
mandatoryParameters
optionalParameters
_) -> do
outputStrLn $ "Usage: " ++ commandName
++ mandatoryParameterDescription
++ optionalParameterDescription
outputStrLn $ ""
where
mandatoryParameterDescription :: String
mandatoryParameterDescription =
if null mandatoryParameters
then ""
else " " ++ (intercalate " "
$ map describeParameter mandatoryParameters)
optionalParameterDescription :: String
optionalParameterDescription =
if null optionalParameters
then ""
else " " ++ optionalParameterDescription' optionalParameters
optionalParameterDescription' :: [Parameter] -> String
optionalParameterDescription' (only:[]) =
"[" ++ describeParameter only ++ "]"
optionalParameterDescription' (item:rest) =
"[" ++ describeParameter item ++ " "
++ optionalParameterDescription' rest ++ "]"
describeParameter :: Parameter -> String
describeParameter StringParameter = "string"
describeParameter InputFileParameter = "input-file"
where
outputTabularList :: [String] -> InputT IO ()
outputTabularList items = do
let lineLoop [] = return ()
lineLoop items = do
let here = take 5 items
rest = drop 5 items
outputStrLn $ concat $ [" "]
++ (map (\item ->
replicate (15 - length item) ' ')
(init here))
++ [last here]
case rest of
[] -> return ()
_ -> lineLoop rest
lineLoop items
commandNamesForCategory :: CommandCategory -> [String]
commandNamesForCategory category =
sort $ map (\(Command _ name _ _ _) -> name)
$ filter (\(Command foundCategory _ _ _ _) ->
category == foundCategory)
$ Map.elems commandTable
commandMD5 :: ByteString -> InputT IO ()
commandMD5 input = do
let output = BS.pack $ MD5.hash $ BS.unpack input
outputHex output
smartWords :: String -> [String]
smartWords input =
let (result, _, _) =
foldl (\(result, inWord, inQuotes) c ->
let (newInWord, newInQuotes, shouldCollect) =
case (inQuotes, isSpace c, c) of
(True, False, '"') -> (True, False, False)
(True, _, _) -> (True, True, True)
(False, False, '"') -> (True, True, False)
(False, False, _) -> (True, False, True)
(False, True, _) -> (False, False, False)
newResult =
if shouldCollect
then if inWord
then init result ++ [last result ++ [c]]
else result ++ [[c]]
else result
in (newResult, newInWord, newInQuotes))
([], False, False)
input
in result
outputHex :: ByteString -> InputT IO ()
outputHex bytestring = do
let toHex :: Word8 -> String
toHex word = case showHex word "" of
all@(c1:c2:[]) -> all
c2:[] -> '0':c2:[]
outputStrLn $ concat $ map toHex $ BS.unpack bytestring