История изменений

catching :: IO a -> (SomeException -> IO a) -> IO a
catching = catch

instance Alternative IO where
  empty = error "empty IO" -- throwIO (EmptyIO :: EmptyIO)
  a <|> b = catching a (const b)

unlessM :: Monad m => m Bool -> m () -> m ()
unlessM p a = p >>= (`unless` a)

synA :: Applicative f => (f b -> t) -> f (a -> b) -> f a -> t
synA from guar to = from $ guar <*> to

synM :: Monad m => ((a -> m ()) -> t) -> (a -> m Bool) -> (a -> m ()) -> t
synM from guar = synA from (unlessM . guar)

-- Binary [?] -> ?

fromBinaryList :: Binary e => FilePath -> (e -> IO a) -> IO ()
fromBinaryList path f = mapM_ f =<< decodeFile path

-- ? -> HashTable ?

synToHT :: (Eq k, Hashable k, HashTable h) =>
  ((v -> IO ()) -> t) -> (v -> k) -> IOHashTable h k v -> t
synToHT f key ht = synM f (fmap isJust . HT.lookup ht . key) $ HT.insert ht =<< key

-- User

data User = User
  { _login :: !ByteString, _uid :: !Word, _gid :: !Word
  , _name :: !ByteString, _home :: !ByteString, _shell :: !ByteString
  } deriving ( Show, Eq, Generic )

-- Binary [User]

instance Binary User where

-- HashTable User

type MyHT = BasicHashTable ByteString User

-- Binary [User] -> HashTable User

synBinaryUsersToHT :: FilePath -> MyHT -> IO ()
synBinaryUsersToHT = (`synToHT` _name) . fromBinaryList

-- Passwd -> ? User

fromPasswd :: (User -> IO a) -> IO ()
fromPasswd f = (mapM_ (f . readUser) . BS8.lines =<< BS.readFile "/etc/passwd")
               <|> error "while reading /etc/passwd" where
  readUser bs = case BS8.split ':' bs of
    [login, _, uid, gid, name, home, shell] ->
      User login (read $ BS8.unpack uid) (read $ BS8.unpack gid) name home shell
      -- read :: Read a => ByteString -> a ?

-- Passwd -> HashTable User

synPasswdToHT :: MyHT -> IO ()
synPasswdToHT = synToHT fromPasswd _name

test :: IO ()
test = do
  
  let root = User "root" 0 0 "root" "/root" "sh"
      user = User "user" 1 1 "user" "/user" "sh"

  encodeFile "/tmp/test" [root, user]
  ht <- HT.new
  synBinaryUsersToHT "/tmp/test" ht
  root' <- HT.lookup ht "root"
  user' <- HT.lookup ht "user"
  assert (isJust root' && isJust user' && root == fromJust root' && user == fromJust user') $! return ()

  ht <- HT.new
  synPasswdToHT ht
  mapM_ print =<< HT.toList ht

catching :: IO a -> (SomeException -> IO a) -> IO a
catching = catch

instance Alternative IO where
  empty = error "empty IO" -- throwIO (EmptyIO :: EmptyIO)
  a <|> b = catching a (const b)

unlessM :: Monad m => m Bool -> m () -> m ()
unlessM p a = p >>= (`unless` a)

synA :: Applicative f => (f b -> t) -> f (a -> b) -> f a -> t
synA from guar to = from $ guar <*> to

synM :: Monad m => ((a -> m ()) -> t) -> (a -> m Bool) -> (a -> m ()) -> t
synM from guar = synA from (unlessM . guar)

-- Binary [?] -> ?

fromBinaryList :: Binary e => FilePath -> (e -> IO a) -> IO ()
fromBinaryList path f = mapM_ f =<< decodeFile path

-- ? -> HashTable ?

synToHT :: (Eq k, Hashable k, HashTable h) =>
  ((v -> IO ()) -> t) -> (v -> k) -> IOHashTable h k v -> t
synToHT f key ht = synM f (fmap isJust . HT.lookup ht . key) $ HT.insert ht =<< key

-- User

data User = User
  { _login :: !ByteString, _uid :: !Word, _gid :: !Word
  , _name :: !ByteString, _home :: !ByteString, _shell :: !ByteString
  } deriving ( Show, Eq, Generic )

-- Binary [User]

instance Binary User where

-- HashTable User

type MyHT = BasicHashTable ByteString User

-- Binary [User] -> HashTable User

synBinaryUsersToHT :: FilePath -> MyHT -> IO ()
synBinaryUsersToHT = (`synToHT` _name) . fromBinaryList

-- Passwd -> ? User

fromPasswd :: (User -> IO a) -> IO ()
fromPasswd f = (mapM_ (f . readUser) . BS8.lines =<< BS.readFile "/etc/passwd")
               <|> error "while reading /etc/passwd" where
  readUser bs = case BS8.split ':' bs of
    [login, _, uid, gid, name, home, shell] ->
      User login (read $ BS8.unpack uid) (read $ BS8.unpack gid) name home shell
      -- read :: Read a => ByteString -> a ?

-- Passwd -> HashTable User

synPasswdToHT :: MyHT -> IO ()
synPasswdToHT = synToHT fromPasswd _name

test :: IO ()
test = do
  
  let root = User "root" 0 0 "root" "/root" "sh"
      user = User "user" 1 1 "user" "/user" "sh"

  encodeFile "/tmp/test" [root, user]
  ht <- HT.new
  synBinaryUsersToHT "/tmp/test2" ht
  root' <- HT.lookup ht "root"
  user' <- HT.lookup ht "user"
  assert (isJust root' && isJust user' && root == fromJust root' && user == fromJust user') $! return ()

  ht <- HT.new
  synPasswdToHT ht
  mapM_ print =<< HT.toList ht