diff options
-rw-r--r-- | hosts.hs | 107 |
1 files changed, 107 insertions, 0 deletions
diff --git a/hosts.hs b/hosts.hs new file mode 100644 index 0000000..afd60fc --- /dev/null +++ b/hosts.hs | |||
@@ -0,0 +1,107 @@ | |||
1 | import Data.Maybe | ||
2 | import Data.List | ||
3 | import Data.Either | ||
4 | import Control.Monad | ||
5 | import System.Environment | ||
6 | import Hosts | ||
7 | import qualified Data.ByteString.Lazy.Char8 as L | ||
8 | import System.IO | ||
9 | import System.Exit | ||
10 | import Network.Socket ( SockAddr ) | ||
11 | |||
12 | data HostsArgs addr = HostsArgs | ||
13 | { dbfile :: FilePath | ||
14 | , hquery :: Bool | ||
15 | , makeCanon :: Bool | ||
16 | , keyvals :: [(String,addr)] | ||
17 | } | ||
18 | deriving (Eq,Show) | ||
19 | |||
20 | parseArgs :: [String] -> (HostsArgs String, String) | ||
21 | parseArgs args = ( HostsArgs { dbfile = dbfile | ||
22 | , hquery = hquery | ||
23 | , makeCanon = canon | ||
24 | , keyvals = keyvals } | ||
25 | , bad ) | ||
26 | where | ||
27 | singles = "lc" | ||
28 | doubles = "f" | ||
29 | |||
30 | filterDoubles (x:xs) = | ||
31 | if take 2 x `elem` map (\c->'-':c:[]) doubles | ||
32 | then let (ds,ns) = filterDoubles xs' | ||
33 | (x',xs') = case drop 1 x of | ||
34 | [c] -> (c:concat (take 1 xs), drop 1 xs) | ||
35 | v -> (v, xs) | ||
36 | in (x':ds, ns) | ||
37 | else let (ds,ns) = filterDoubles xs | ||
38 | in (ds, x:ns) | ||
39 | filterDoubles _ = ([],[]) | ||
40 | |||
41 | pairs (x:y:ys) = (x,y):pairs ys | ||
42 | pairs _ = [] | ||
43 | |||
44 | (as,bs) = span (/="--") args | ||
45 | (dbs,as') = filterDoubles as | ||
46 | (ss0,as'') = partition ("-" `isPrefixOf`) as' | ||
47 | ss = ss0 >>= drop 1 | ||
48 | (ks,bad) = partition (`elem` singles) ss | ||
49 | |||
50 | dbfile = case drop 1 $ concat $ take 1 $ filter ("f" `isPrefixOf`) dbs of | ||
51 | "" -> "/etc/hosts" | ||
52 | x -> x | ||
53 | hquery = 'l' `elem` ks | ||
54 | canon = 'c' `elem` ks | ||
55 | keyvals = pairs $ as'' ++ drop 1 bs | ||
56 | |||
57 | |||
58 | |||
59 | |||
60 | crap strs = do | ||
61 | forM_ strs $ hPutStrLn stderr | ||
62 | exitFailure | ||
63 | |||
64 | grokPairing :: Bool -> Hosts -> (String,Either String SockAddr) -> Hosts | ||
65 | grokPairing bCanon hosts (name,eaddr) = | ||
66 | case eaddr of | ||
67 | Right addr -> assign addr (L.pack name) hosts | ||
68 | Left "delete" -> error "deletion not implemented." | ||
69 | where | ||
70 | assign = if bCanon then assignNewName else assignName | ||
71 | |||
72 | main = do | ||
73 | args <- getArgs | ||
74 | let (cmd,badness) = parseArgs args | ||
75 | if not (null badness) | ||
76 | then crap ["Bad options: " ++ badness] | ||
77 | else do | ||
78 | let cmd' = cmd { keyvals = map (\(n,a) -> (n, maybe (Left a) Right $ inet_pton a)) | ||
79 | $ keyvals cmd } | ||
80 | let badaddrs = filter (/="delete") $ lefts (map snd $ keyvals cmd') | ||
81 | if not $ null badaddrs | ||
82 | then crap $ map ("Expected \"delete\" or an ip address: "++) badaddrs | ||
83 | else do | ||
84 | if null $ keyvals cmd' | ||
85 | then crap ["hosts [-f file] [-l | -c] hostname (address|delete) ..." | ||
86 | ,"" | ||
87 | ," address: an ip address" | ||
88 | ," delete: the literal word \"delete\"" | ||
89 | ," hostname: a host name to assign to" | ||
90 | ," file: a file to edit (default: /etc/hosts)" | ||
91 | ,"" | ||
92 | ," -l Instead of editing, set error code to indicate the" | ||
93 | ," absense of a pairing" | ||
94 | ,"" | ||
95 | ," -c New assignments will change the cannonical name for" | ||
96 | ," the given address." | ||
97 | ] | ||
98 | else do | ||
99 | return () | ||
100 | hosts <- fmap decode $ L.readFile (dbfile cmd') | ||
101 | if hquery cmd' then crap ["query not implemented"] else do | ||
102 | let hosts' = foldl' (grokPairing (makeCanon cmd')) | ||
103 | hosts | ||
104 | (keyvals cmd') | ||
105 | d = diff hosts hosts' | ||
106 | forM_ d $ L.putStrLn | ||
107 | L.writeFile (dbfile cmd') (encode hosts') | ||