blob: 808e6dd86a982fb0588ee46c6201b220e8de16da (
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
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
|
{-# LANGUAGE OverloadedStrings #-}
module ConfigFiles where
import Data.ByteString.Lazy.Char8 as L
import System.Posix.User
import System.Posix.Files (fileExist)
import System.FilePath
import System.Directory
import System.IO
-- import System.IO.Strict
import System.IO.Error
import Control.Exception
import Control.Monad
import Control.DeepSeq
import ByteStringOperators () -- For NFData instance
import ControlMaybe
import Data.List (partition)
import Data.Maybe (catMaybes,isJust)
type User = ByteString
configDir = ".presence"
buddyFile = "buddies"
subscriberFile = "subscribers"
otherFile = "others"
pendingFile = "pending"
solicitedFile = "solicited"
configPath :: User -> String -> IO String
configPath user filename = do
ue <- getUserEntryForName (unpack user)
return $ (++("/"++configDir++"/"++filename)) $ homeDirectory ue
createConfigFile tag path = do
let dir = dropFileName path
doesDirectoryExist dir >>= flip unless (do
createDirectory dir
)
withFile path WriteMode $ \h -> do
L.hPutStrLn h tag
addItem item tag path =
let doit = do
handle (\e -> when (isDoesNotExistError e)
(createConfigFile tag path >> doit))
$ do exists <- fileExist path
if exists
then withFile path AppendMode $ \h ->
L.hPutStrLn h item
else withFile path WriteMode $ \h -> do
L.hPutStrLn h tag
L.hPutStrLn h item
in doit
modifyFile ::
(ByteString,FilePath)
-> ByteString
-> (ByteString -> IO (Maybe ByteString))
-> Maybe ByteString
-> IO Bool -- Returns True if test function ever returned Nothing
modifyFile (tag,file) user test appending = configPath user file >>= doit
where
doit path = do
handle (\e -> if (isDoesNotExistError e)
then (createConfigFile tag path >> doit path)
else return False)
$ do exists <- fileExist path
if exists
then do
xs <- withFile path ReadMode $ \h -> do
contents <- L.hGetContents h
case L.lines contents of
x:xs -> mapM test xs
_ -> return []
let (keepers,deleted) = partition isJust xs
withFile path WriteMode $ \h -> do
L.hPutStrLn h tag
forM_ (catMaybes keepers) (L.hPutStrLn h)
withJust appending (L.hPutStrLn h)
return . not . Prelude.null $ deleted
else do
withFile path WriteMode $ \h -> do
L.hPutStrLn h tag
withJust appending (L.hPutStrLn h)
return False
modifySolicited = modifyFile ("<? solicited ?>" , solicitedFile)
modifyBuddies = modifyFile ("<? buddies ?>" , buddyFile)
modifyOthers = modifyFile ("<? others ?>" , otherFile)
modifyPending = modifyFile ("<? pending ?>" , pendingFile)
modifySubscribers = modifyFile ("<? subscribers ?>", subscriberFile)
addBuddy :: User -> ByteString -> IO ()
addBuddy user buddy =
configPath user buddyFile >>= addItem buddy "<? buddies ?>"
addSubscriber :: User -> ByteString -> IO ()
addSubscriber user subscriber =
configPath user subscriberFile >>= addItem subscriber "<? subscribers ?>"
addSolicited :: User -> ByteString -> IO ()
addSolicited user solicited =
configPath user solicitedFile >>= addItem solicited "<? solicited ?>"
getConfigList path =
handle (\e -> if isDoesNotExistError e then (return []) else throw e)
$ withFile path ReadMode $
L.hGetContents
>=> return . Prelude.tail . L.lines
>=> (\a -> seq (rnf a) (return a))
getBuddies :: User -> IO [ByteString]
getBuddies user = configPath user buddyFile >>= getConfigList
getSubscribers :: User -> IO [ByteString]
getSubscribers user = configPath user subscriberFile >>= getConfigList
getOthers :: User -> IO [ByteString]
getOthers user = configPath user otherFile >>= getConfigList
getPending :: User -> IO [ByteString]
getPending user = configPath user pendingFile >>= getConfigList
getSolicited :: User -> IO [ByteString]
getSolicited user = configPath user solicitedFile >>= getConfigList
|
