summaryrefslogtreecommitdiff
path: root/lib/Kiki.hs
diff options
context:
space:
mode:
Diffstat (limited to 'lib/Kiki.hs')
-rw-r--r--lib/Kiki.hs86
1 files changed, 72 insertions, 14 deletions
diff --git a/lib/Kiki.hs b/lib/Kiki.hs
index 0684830..6717c4b 100644
--- a/lib/Kiki.hs
+++ b/lib/Kiki.hs
@@ -1,4 +1,5 @@
1{-# LANGUAGE CPP #-} 1{-# LANGUAGE CPP #-}
2{-# LANGUAGE OverloadedStrings #-}
2module Kiki where 3module Kiki where
3 4
4import Control.Applicative 5import Control.Applicative
@@ -10,6 +11,7 @@ import Data.ASN1.Types
10import Data.Binary 11import Data.Binary
11import Data.List 12import Data.List
12import Data.Maybe 13import Data.Maybe
14import Data.Monoid
13import Data.OpenPGP 15import Data.OpenPGP
14import Data.OpenPGP.Util 16import Data.OpenPGP.Util
15import Data.Ord 17import Data.Ord
@@ -207,16 +209,23 @@ refreshCache rt rootdir = do
207 209
208 let mkpath pth = fromMaybe "" rootdir ++ "/var/cache/kiki/"++pth 210 let mkpath pth = fromMaybe "" rootdir ++ "/var/cache/kiki/"++pth
209 211
210 write f bs = do 212 write' wr f bs = do
211 createDirectoryIfMissing True $ takeDirectory f 213 createDirectoryIfMissing True $ takeDirectory f
212 writeFile f bs 214 wr f bs
215 write = write' writeFile
216 writeL = write' L.writeFile
213 217
214 let oname' = do wk <- rtWorkingKey rt 218 let names = do wk <- rtWorkingKey rt
215 -- XXX unnecessary signature check 219 -- XXX unnecessary signature check
216 onionNameForContact (keykey wk) (rtKeyDB rt) 220 return $ getHostnames (rtKeyDB rt Map.! keykey wk)
217 bUnprivileged = False -- TODO 221 bUnprivileged = False -- TODO
218 if (oname' == Nothing) && (not bUnprivileged) then error "Missing tor key" else do 222 oname = Char8.concat $ do
219 let oname = fromMaybe "" oname' 223 (_,(os,_)) <- maybeToList names
224 take 1 os
225 fromMaybe (error "No working key.") $ do
226 (wkaddr,_) <- names
227 Just $ do
228 if (oname == "") && (not bUnprivileged) then error "Missing tor key" else do
220 -- sshcpathpub0 = fromMaybe "" rootdir ++ osHomeDir </> ".ssh" </> "id_rsa.pub" 229 -- sshcpathpub0 = fromMaybe "" rootdir ++ osHomeDir </> ".ssh" </> "id_rsa.pub"
221 -- sshspathpub0 = fromMaybe "" rootdir ++ "/etc/ssh/ssh_host_rsa_key.pub" 230 -- sshspathpub0 = fromMaybe "" rootdir ++ "/etc/ssh/ssh_host_rsa_key.pub"
222 -- contactipsec0 = fromMaybe "" rootdir ++ "/etc/ipsec.d/certs/%(onion).pem" 231 -- contactipsec0 = fromMaybe "" rootdir ++ "/etc/ipsec.d/certs/%(onion).pem"
@@ -227,29 +236,78 @@ refreshCache rt rootdir = do
227 $ show_ssh' "ssh-client" grip (rtKeyDB rt) 236 $ show_ssh' "ssh-client" grip (rtKeyDB rt)
228 either warn (write $ mkpath "ssh_host_rsa_key.pub") 237 either warn (write $ mkpath "ssh_host_rsa_key.pub")
229 $ show_ssh' "ssh-server" grip (rtKeyDB rt) 238 $ show_ssh' "ssh-server" grip (rtKeyDB rt)
230 either warn (write $ mkpath "ipsec.d/certs/" ++ oname++".pem") 239 either warn (write $ mkpath "ipsec.d/certs/" ++ Char8.unpack oname++".pem")
231 $ show_pem' "ipsec" grip (rtKeyDB rt) pemFromPacket 240 $ show_pem' "ipsec" grip (rtKeyDB rt) pemFromPacket
232 241
233 let cs = filter notme (Map.elems $ rtKeyDB rt) 242 let cs = filter notme (Map.elems $ rtKeyDB rt)
234 kk = keykey (fromJust $ rtWorkingKey rt) 243 kk = keykey (fromJust $ rtWorkingKey rt)
235 notme kd = keykey (keyPacket kd) /= kk 244 notme kd = keykey (keyPacket kd) /= kk
236 245
246 installConctact :: KeyData -> IO Char8.ByteString
237 installConctact kd = do 247 installConctact kd = do
238 -- The getHostnames command requires a valid cross-signed tor key 248 -- The getHostnames command requires a valid cross-signed tor key
239 -- for each onion name returned in (_,(ns,_)). 249 -- for each onion name returned in (_,(ns,_)).
240 let (_,(ns,_)) = getHostnames kd 250 let (addr,(ns,_)) = getHostnames kd
241 contactname = fmap Char8.unpack $ listToMaybe ns -- only first onion name. 251 contactname = fmap Char8.unpack $ listToMaybe ns -- only first onion name.
242 flip (maybe $ return ()) contactname $ \contactname -> do 252 flip (maybe $ return Char8.empty) contactname $ \contactname -> do
243 253
244 let cpath = interp (Map.singleton "onion" contactname) "ipsec.d/certs/%(onion).pem" 254 let cpath = interp (Map.singleton "onion" contactname) "ipsec.d/certs/%(onion).pem"
245 their_master = packet $ keyMappedPacket kd 255 their_master = packet $ keyMappedPacket kd
246 -- We find all cross-certified ipsec keys for the given cross-certified onion name. 256 -- We find all cross-certified ipsec keys for the given cross-certified onion name.
257 ipsecs :: [Packet]
247 ipsecs = sortOn (Down . timestamp) 258 ipsecs = sortOn (Down . timestamp)
248 $ getCrossSignedSubkeys their_master (keySubKeys kd) "ipsec" 259 $ getCrossSignedSubkeys their_master (keySubKeys kd) "ipsec"
249 forM_ (take 1 ipsecs) $ \k -> do 260 bss <- forM (take 1 ipsecs) $ \k -> do
250 either warn (write $ mkpath cpath) $ pemFromPacket k 261 let warn' x = warn x >> return Char8.empty
251 262 flip (either warn') (pemFromPacket k :: Either String String) $ \pem -> do
252 mapM_ installConctact cs 263 write (mkpath cpath) pem
264 return $ strongswanForContact addr contactname
265 return $ Char8.concat bss
266
267 cons <- mapM installConctact cs
268 writeL (mkpath "ipsec.conf") . Char8.unlines
269 $ [ "conn %default"
270 , " ikelifetime=60m"
271 , " keylife=20m"
272 , " rekeymargin=3m"
273 , " keyingtries=%forever"
274 , " keyexchange=ikev2"
275 , " dpddelay=10s"
276 , " dpdaction=restart"
277 , " left=%defaultroute"
278 , " leftsubnet=" <> Char8.pack (showA wkaddr) <> "/128"
279 , " leftauth=pubkey"
280 , " leftid=" <> Char8.pack (showA wkaddr)
281 , " leftrsasigkey=" <> oname
282 , " leftikeport=4500"
283 , " rightikeport=4500"
284 , " right=%any"
285 , " rightauth=pubkey"
286 , " type=tunnel"
287 , " auto=route"
288 , ""
289 ] ++ filter (not . Char8.null) cons
290 return ()
291
292strongswanForContact addr oname = Char8.unlines
293 [ "conn " <> p oname
294 , " right=%" <> p oname <> ".ipv4"
295 , " rightsubnet=" <> p (showA addr) <> "/128"
296 , " rightauth=pubkey"
297 , " rightid=" <> p (showA addr)
298 , " rightrsasigkey=" <> p (oname) <> ".pem"
299 ]
300 where p = Char8.pack
301
302-- conn hiotuxliwisbp6mi.onion
303-- right=%hiotuxliwisbp6mi.onion.ipv4
304-- rightsubnet=fdcc:76c8:cb34:74e6:2aa3:cb39:abc8:d403/128
305-- rightauth=pubkey
306-- rightid=fdcc:76c8:cb34:74e6:2aa3:cb39:abc8:d403
307-- rightrsasigkey=hiotuxliwisbp6mi.onion.pem
308
309showA addr = if null bracket then pre else drop 1 pre
310 where (pre,bracket) = break (==']') (show addr)
253 311
254 312
255#if !MIN_VERSION_base(4,8,0) 313#if !MIN_VERSION_base(4,8,0)