summaryrefslogtreecommitdiff
path: root/hosts.hs
blob: 8aa602792b93e52baf72f92968fb62c2d3005c35 (plain)
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
import Data.Maybe
import Data.List
import Data.Either
import Control.Monad
import System.Environment
import Hosts
import qualified Data.ByteString.Lazy.Char8 as L
import System.IO
import System.Exit
import Network.Socket ( SockAddr )

data HostsArgs addr = HostsArgs
    { dbfile :: FilePath
    , hquery :: Bool
    , makeCanon :: Bool
    , keyvals :: [(String,addr)]
    }
 deriving (Eq,Show)

parseArgs :: [String] -> (HostsArgs String, String)
parseArgs args = ( HostsArgs { dbfile = dbfile
                             , hquery = hquery
                             , makeCanon = canon
                             , keyvals = keyvals }
                 , bad )
 where
    singles = "lc"
    doubles = "f"

    filterDoubles (x:xs) =
        if take 2 x `elem` map (\c->'-':c:[]) doubles
            then let (ds,ns) = filterDoubles xs'
                     (x',xs') = case drop 1 x of
                                    [c] -> (c:concat (take 1 xs), drop 1 xs)
                                    v -> (v, xs)
                 in (x':ds, ns)
            else let (ds,ns) = filterDoubles xs
                 in (ds, x:ns)
    filterDoubles _ = ([],[])

    pairs (x:y:ys) = (x,y):pairs ys
    pairs _        = []

    (as,bs) = span (/="--") args
    (dbs,as') = filterDoubles as
    (ss0,as'') = partition ("-" `isPrefixOf`) as'
    ss = ss0 >>= drop 1
    (ks,bad) = partition (`elem` singles) ss

    dbfile = case drop 1 $ concat $ take 1 $ filter ("f" `isPrefixOf`) dbs of
                "" -> "/etc/hosts"
                x  -> x
    hquery = 'l' `elem` ks
    canon  = 'c' `elem` ks
    keyvals = pairs $ as'' ++ drop 1 bs




crap strs = do
    forM_ strs $ hPutStrLn stderr
    exitFailure

grokPairing :: Bool -> Hosts -> (String,Either String SockAddr) -> Hosts
grokPairing bCanon hosts (name,eaddr) =
    case eaddr of
        Right addr -> assignName' bCanon addr (L.pack name) hosts
        Left "delete" -> removeName (L.pack name) hosts

main = do
    args <- getArgs
    let (cmd,badness) = parseArgs args
    if not (null badness)
        then crap ["Bad options: " ++ badness]
        else do
    let cmd' = cmd { keyvals = map (\(n,a) -> (n, maybe (Left a) Right $ inet_pton a))
                                $ keyvals cmd }
    let badaddrs = filter (/="delete") $ lefts (map snd $ keyvals cmd')
    if not $ null badaddrs
        then crap $ map ("Expected \"delete\" or an ip address: "++) badaddrs
        else do
    if null $ keyvals cmd'
        then crap ["hosts [-f FILE] [-l | -c] HOSTNAME (ADDRESS|delete) ..."
                  ,""
                  ,"  ADDRESS:  an ip address"
                  ,"  delete:   the literal word \"delete\""
                  ,"  HOSTNAME: a host name to assign to"
                  ,"  FILE:     a file to edit (default: /etc/hosts)"
                  ,""
                  ,"  -l  Instead of editing, set error code to indicate the"
                  ,"      absense of a pairing"
                  ,""
                  ,"  -c  New assignments will change the cannonical name for"
                  ,"      the given address."
                  ]
        else do
    return ()
    hosts <- fmap decode $ L.readFile (dbfile cmd')
    if hquery cmd' then crap ["query not implemented"] else do
    let hosts' = foldl' (grokPairing (makeCanon cmd'))
                        hosts
                        (keyvals cmd')
        d = diff hosts hosts'
    forM_ d $ L.putStrLn
    L.writeFile (dbfile cmd') (encode hosts')