src/Gargantext/Prelude/Crypto/Pass.hs

   1 {-|
   2 Module      : Gargantext.Prelude.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.Prelude.Crypto.Pass
  20       where
  21
  22 import Data.List (nub)
  23 -- import System.Environment (getArgs)
  24 -- import System.IO (hSetEcho)
  25 import Data.Text (Text)
  26 import Control.Monad.State
  27 import Crypto.Random (cprgGenerate)
  28 import Crypto.Random.AESCtr
  29 import Data.Binary (decode)
  30 import Prelude
  31 import qualified Data.ByteString.Lazy as B
  32 import Gargantext.Prelude (cs)
  33 import Data.ByteString as S (ByteString, unpack)
  34 import Data.ByteString.Char8 as C8 (pack)
  35 import Data.Char (chr)
  36
  37 strToBS :: String -> S.ByteString
  38 strToBS = C8.pack
  39
  40 bsToStr :: S.ByteString -> String
  41 bsToStr = map (chr . fromEnum) . S.unpack
  42
  43
  44 keysChar, keysNum, keysPunc, keysCharNum, keysAll, keysHex :: String
  45 keysChar = ['a'..'z'] ++ ['A'..'Z']
  46 keysHex = ['a'..'f']
  47 keysNum = ['0'..'9']
  48 keysPunc = "`~!@#$%^&*()-_=+[{]}\\|;:'\",<.>/? "
  49 keysCharNum = keysChar ++ keysNum
  50 keysAll = keysChar ++ keysNum ++ keysPunc
  51
  52 giveKey ::  String -> Char -> Int -> Char
  53 giveKey keysCustom c n = extractChar $ case c of
  54     'i'  -> (keysNum ++ keysHex)
  55     'j'  -> keysNum
  56     'k'  -> keysChar
  57     'l'  -> keysCharNum
  58     ';'  -> keysPunc
  59     'h'  -> (keysCharNum ++ keysCustom)
  60     '\n' -> ['\n']
  61     _    -> keysAll
  62     where
  63     extractChar xs = xs!!mod n (length xs)
  64
  65 showRandomKey :: Int -> String -> StateT AESRNG IO ()
  66 showRandomKey len keysCustom = handleKey =<< liftIO getChar
  67     where
  68     handleKey key = case key of
  69         '\n' -> liftIO (putChar '\n') >> showRandomKey len keysCustom
  70         'q' -> (liftIO $ putStrLn "\nBye!") >> return ()
  71         _ -> mapM_ f [0..len] >> (liftIO $ putStrLn []) >> showRandomKey len keysCustom
  72         where
  73         f _ = liftIO
  74             . putChar
  75             . giveKey keysCustom key
  76             . (\n -> mod n (length (keysAll ++ keysCustom) - 1))
  77             =<< aesRandomInt
  78
  79
  80 aesRandomInt :: StateT AESRNG IO Int
  81 aesRandomInt = do
  82     aesState <- get
  83     -- aesState <- liftIO makeSystem
  84     -- let aesState = 128
  85     let (bs, aesState') = cprgGenerate 64 aesState
  86     put aesState'
  87     return (decode $ B.fromChunks [bs])
  88
  89 printPass :: Int -> IO ()
  90 printPass len = do
  91   let as = ["alphanumeric","punctuation"]
  92   let as' = filter (\c -> elem c keysAll) . nub $ unwords as
  93   aesState <- makeSystem -- gather entropy from the system to use as the initial seed
  94   _ <- runStateT (showRandomKey len as') aesState -- enter loop
  95   return ()
  96
  97 gargPass :: IO (Int, AESRNG)
  98 gargPass = do
  99   aesState <- makeSystem -- gather entropy from the system to use as the initial seed
 100   pass <- runStateT aesRandomInt aesState -- enter loop
 101   pure pass
 102
 103 gargPass' :: IO Text
 104 gargPass' = do
 105   aesState <- makeSystem
 106   let (bs, _aesState') = cprgGenerate 15 aesState
 107   return (cs $ bsToStr bs)
 108
 109 {-
 110 main :: IO ()
 111 main = do
 112     hSetBuffering stdin NoBuffering  -- disable buffering from STDIN
 113     hSetBuffering stdout NoBuffering -- disable buffering from STDOUT
 114     hSetEcho stdin False             -- disable terminal echo
 115     as <- getArgs
 116     let as' = filter (\c -> elem c keysAll) . nub $ unwords as
 117     mapM_ putStrLn
 118         [ []
 119         , "poke: 'q'     quit"
 120         , "      'j'     number"
 121         , "      'k'     letter"
 122         , "      'l'     alphanumeric"
 123         , "      ';'     punctuation"
 124         , "      'h'     alphanumeric" ++ (if null as' then [] else " + " ++ as')
 125         , "      'i'     hexadecimal"
 126         , "      'ENTER' newline"
 127         , "      else    any"
 128         , []
 129         ]
 130     aesState <- makeSystem -- gather entropy from the system to use as the initial seed
 131     _ <- runStateT (showRandomKey as') aesState -- enter loop
 132     return ()
 133 -}