]> Git — Sourcephile - gargantext.git/blob - src/Gargantext/Core/Crypto/Pass.hs
[Crypto] files now in G.Core.Crypto
[gargantext.git] / src / Gargantext / Core / Crypto / Pass.hs
1 {-|
2 Module : Gargantext.Core.Crypto.Pass
3 Description :
4 Copyright : (c) CNRS, 2017-Present
5 License : Public Domain
6 Maintainer : team@gargantext.org
7 Stability : experimental
8 Portability : POSIX
9
10 To avoid weak password, just offer an easy way to make "good" one and
11 let user add his own entropy.
12
13 Thanks to
14 https://zuttobenkyou.wordpress.com/2011/12/23/simple-password-generation-with-haskell/
15
16 -}
17
18
19 module Gargantext.Core.Crypto.Pass
20 where
21
22 -- import Data.List (nub)
23 -- import System.Environment (getArgs)
24 -- import System.IO (hSetEcho)
25 import Control.Monad.State
26 import Crypto.Random (cprgGenerate)
27 import Crypto.Random.AESCtr
28 import Data.Binary (decode)
29 import Prelude
30 import qualified Data.ByteString.Lazy as B
31
32
33 keysChar, keysNum, keysPunc, keysCharNum, keysAll, keysHex :: String
34 keysChar = ['a'..'z'] ++ ['A'..'Z']
35 keysHex = ['a'..'f']
36 keysNum = ['0'..'9']
37 keysPunc = "`~!@#$%^&*()-_=+[{]}\\|;:'\",<.>/? "
38 keysCharNum = keysChar ++ keysNum
39 keysAll = keysChar ++ keysNum ++ keysPunc
40
41 giveKey :: String -> Char -> Int -> Char
42 giveKey keysCustom c n = extractChar $ case c of
43 'i' -> (keysNum ++ keysHex)
44 'j' -> keysNum
45 'k' -> keysChar
46 'l' -> keysCharNum
47 ';' -> keysPunc
48 'h' -> (keysCharNum ++ keysCustom)
49 '\n' -> ['\n']
50 _ -> keysAll
51 where
52 extractChar xs = xs!!mod n (length xs)
53
54 showRandomKey :: Int -> String -> StateT AESRNG IO ()
55 showRandomKey len keysCustom = handleKey =<< liftIO getChar
56 where
57 handleKey key = case key of
58 '\n' -> liftIO (putChar '\n') >> showRandomKey len keysCustom
59 'q' -> (liftIO $ putStrLn "\nBye!") >> return ()
60 _ -> mapM_ f [0..len] >> (liftIO $ putStrLn []) >> showRandomKey len keysCustom
61 where
62 f _ = liftIO
63 . putChar
64 . giveKey keysCustom key
65 . (\n -> mod n (length (keysAll ++ keysCustom) - 1))
66 =<< aesRandomInt
67
68 aesRandomInt :: StateT AESRNG IO Int
69 aesRandomInt = do
70 aesState <- get
71 -- aesState <- liftIO makeSystem
72 -- let aesState = 128
73 let (bs, aesState') = cprgGenerate 64 aesState
74 put aesState'
75 return (decode $ B.fromChunks [bs])
76
77 gargPass :: IO (Int, AESRNG)
78 gargPass = do
79 -- let as = ["alphanumeric","punctuation"]
80 -- let as' = filter (\c -> elem c keysAll) . nub $ unwords as
81 aesState <- makeSystem -- gather entropy from the system to use as the initial seed
82 --_ <- runStateT (showRandomKey len as') aesState -- enter loop
83 -- return ()
84 pass <- runStateT aesRandomInt aesState -- enter loop
85 pure pass
86
87 {-
88 main :: IO ()
89 main = do
90 hSetBuffering stdin NoBuffering -- disable buffering from STDIN
91 hSetBuffering stdout NoBuffering -- disable buffering from STDOUT
92 hSetEcho stdin False -- disable terminal echo
93 as <- getArgs
94 let as' = filter (\c -> elem c keysAll) . nub $ unwords as
95 mapM_ putStrLn
96 [ []
97 , "poke: 'q' quit"
98 , " 'j' number"
99 , " 'k' letter"
100 , " 'l' alphanumeric"
101 , " ';' punctuation"
102 , " 'h' alphanumeric" ++ (if null as' then [] else " + " ++ as')
103 , " 'i' hexadecimal"
104 , " 'ENTER' newline"
105 , " else any"
106 , []
107 ]
108 aesState <- makeSystem -- gather entropy from the system to use as the initial seed
109 _ <- runStateT (showRandomKey as') aesState -- enter loop
110 return ()
111 -}